From c0aedf960c169d4348d9a0ea1442aafc5780da22 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Thu, 18 Apr 2024 15:00:49 +0800 Subject: [PATCH 01/44] CP-47304: [Toolstack] - Add data model for anti-affinity group CP-47655: [Toolstack] - Associate/disassociate VM to/from anti-affinity group Signed-off-by: Bengang Yuan --- ocaml/idl/datamodel.ml | 3 ++ ocaml/idl/datamodel_common.ml | 2 + ocaml/idl/datamodel_errors.ml | 2 + ocaml/idl/datamodel_vm.ml | 12 +++++ ocaml/idl/datamodel_vm_group.ml | 43 +++++++++++++++++ ocaml/idl/dune | 2 +- ocaml/idl/schematest.ml | 2 +- ocaml/xapi-cli-server/cli_frontend.ml | 18 +++++++ ocaml/xapi-cli-server/cli_operations.ml | 29 +++++++++++ ocaml/xapi-cli-server/record_util.ml | 15 ++++++ ocaml/xapi-cli-server/records.ml | 64 +++++++++++++++++++++++++ ocaml/xapi-consts/api_errors.ml | 2 + ocaml/xapi/api_server.ml | 1 + ocaml/xapi/message_forwarding.ml | 32 +++++++++++++ ocaml/xapi/xapi_vm.ml | 5 ++ ocaml/xapi/xapi_vm.mli | 3 ++ ocaml/xapi/xapi_vm_group.ml | 24 ++++++++++ ocaml/xapi/xapi_vm_group.mli | 22 +++++++++ ocaml/xapi/xapi_vm_helpers.ml | 4 +- ocaml/xe-cli/bash-completion | 7 +++ quality-gate.sh | 2 +- 21 files changed, 290 insertions(+), 4 deletions(-) create mode 100644 ocaml/idl/datamodel_vm_group.ml create mode 100644 ocaml/xapi/xapi_vm_group.ml create mode 100644 ocaml/xapi/xapi_vm_group.mli diff --git a/ocaml/idl/datamodel.ml b/ocaml/idl/datamodel.ml index c8fa2614150..02cd17a1230 100644 --- a/ocaml/idl/datamodel.ml +++ b/ocaml/idl/datamodel.ml @@ -7816,6 +7816,7 @@ let all_system = ; Datamodel_diagnostics.t ; Datamodel_repository.t ; Datamodel_observer.t + ; Datamodel_vm_group.t ] (* If the relation is one-to-many, the "many" nodes (one edge each) must come before the "one" node (many edges) *) @@ -7896,6 +7897,7 @@ let all_relations = ; ((_network_sriov, "physical_PIF"), (_pif, "sriov_physical_PIF_of")) ; ((_network_sriov, "logical_PIF"), (_pif, "sriov_logical_PIF_of")) ; ((_certificate, "host"), (_host, "certificates")) + ; ((_vm, "groups"), (_vm_group, "VMs")) ] let update_lifecycles = @@ -8027,6 +8029,7 @@ let expose_get_all_messages_for = ; _vmpp ; _vmss ; _vm_appliance + ; _vm_group ; _pci ; _pgpu ; _gpu_group diff --git a/ocaml/idl/datamodel_common.ml b/ocaml/idl/datamodel_common.ml index 709cb5eb059..17fd8c3f5c3 100644 --- a/ocaml/idl/datamodel_common.ml +++ b/ocaml/idl/datamodel_common.ml @@ -205,6 +205,8 @@ let _vm_guest_metrics = "VM_guest_metrics" let _vm_appliance = "VM_appliance" +let _vm_group = "VM_group" + let _dr_task = "DR_task" let _vmpp = "VMPP" diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 0bfbaa21039..5cfbe153f63 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1968,6 +1968,8 @@ let _ = error Api_errors.host_evacuation_is_required ["host"] ~doc:"Host evacuation is required before applying updates." () ; + error Api_errors.too_many_groups [] ~doc:"VM can only belong to one group." () ; + message (fst Api_messages.ha_pool_overcommitted) ~doc: diff --git a/ocaml/idl/datamodel_vm.ml b/ocaml/idl/datamodel_vm.ml index c1a6b9a7d9c..c21a831cc33 100644 --- a/ocaml/idl/datamodel_vm.ml +++ b/ocaml/idl/datamodel_vm.ml @@ -1514,6 +1514,15 @@ let set_appliance = ] ~allowed_roles:_R_POOL_OP () +let set_groups = + call ~name:"set_groups" ~lifecycle:[] ~doc:"Associate this VM with VM groups." + ~params: + [ + (Ref _vm, "self", "The VM") + ; (Set (Ref _vm_group), "value", "The VM groups to set") + ] + ~allowed_roles:_R_VM_ADMIN () + let call_plugin = call ~name:"call_plugin" ~in_product_since:rel_cream ~doc:"Call an API plugin on this vm" @@ -1826,6 +1835,7 @@ let t = ; recover ; import_convert ; set_appliance + ; set_groups ; query_services ; call_plugin ; set_has_vendor_device @@ -2174,6 +2184,8 @@ let t = user should follow to make some updates, e.g. specific hardware \ drivers or CPU features, fully effective, but the 'average user' \ doesn't need to" + ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:(Set (Ref _vm_group)) + "groups" "VM groups associated with the VM" ] ) () diff --git a/ocaml/idl/datamodel_vm_group.ml b/ocaml/idl/datamodel_vm_group.ml new file mode 100644 index 00000000000..58016a31d0a --- /dev/null +++ b/ocaml/idl/datamodel_vm_group.ml @@ -0,0 +1,43 @@ +(* + * Copyright (c) Cloud Software Group, 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 Datamodel_types +open Datamodel_common +open Datamodel_roles + +let placement_policy = + Enum + ( "placement_policy" + , [ + ("anti_affinity", "Anti-affinity placement policy") + ; ("normal", "Default placement policy") + ] + ) + +let t = + create_obj ~name:_vm_group ~descr:"A VM group" ~doccomments:[] + ~gen_constructor_destructor:true ~gen_events:true ~in_db:true ~lifecycle:[] + ~persist:PersistEverything ~in_oss_since:None + ~messages_default_allowed_roles:_R_VM_ADMIN ~messages:[] + ~contents: + [ + uid _vm_group + ; namespace ~name:"name" ~contents:(names None RW) () + ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:placement_policy "placement" + ~default_value:(Some (VEnum "normal")) + "The placement policy of the VM group" + ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:(Set (Ref _vm)) "VMs" + "The list of VMs associated with the group" + ] + () diff --git a/ocaml/idl/dune b/ocaml/idl/dune index 713462e7ffa..837c3b0013a 100644 --- a/ocaml/idl/dune +++ b/ocaml/idl/dune @@ -6,7 +6,7 @@ datamodel_pool datamodel_cluster datamodel_cluster_host dm_api escaping datamodel_values datamodel_schema datamodel_certificate datamodel_diagnostics datamodel_repository datamodel_lifecycle - datamodel_vtpm datamodel_observer) + datamodel_vtpm datamodel_observer datamodel_vm_group) (libraries ppx_sexp_conv.runtime-lib rpclib.core diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index c8e5972c9a6..f1af08a92f6 100644 --- a/ocaml/idl/schematest.ml +++ b/ocaml/idl/schematest.ml @@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex (* BEWARE: if this changes, check that schema has been bumped accordingly in ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *) -let last_known_schema_hash = "186131ad48f40dff30246e8e0c0dbf0a" +let last_known_schema_hash = "bd7bd80ec18a0a7ddce47dcfdaa726b5" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index f8aa043eb5a..8a8863e6641 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -2647,6 +2647,24 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [] } ) + ; ( "vm-group-create" + , { + reqd= ["name-label"; "placement"] + ; optn= ["name-description"] + ; help= "Create a VM group." + ; implementation= No_fd Cli_operations.VM_group.create + ; flags= [] + } + ) + ; ( "vm-group-destroy" + , { + reqd= ["uuid"] + ; optn= [] + ; help= "Destroy a VM group." + ; implementation= No_fd Cli_operations.VM_group.destroy + ; flags= [] + } + ) ; ( "diagnostic-vm-status" , { reqd= ["uuid"] diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index bc0d9ea30bc..5486142552a 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -1140,6 +1140,11 @@ let gen_cmds rpc session_id = mk get_all_records_where get_by_uuid vm_appliance_record "appliance" [] [] rpc session_id ) + ; Client.VM_group.( + mk get_all_records_where get_by_uuid vm_group_record "vm-group" [] + ["uuid"; "name-label"; "name-description"; "placement"; "vm-uuids"] + rpc session_id + ) ; Client.PGPU.( mk get_all_records_where get_by_uuid pgpu_record "pgpu" [] ["uuid"; "vendor-name"; "device-name"; "gpu-group-uuid"] @@ -7988,3 +7993,27 @@ module Observer = struct let self = Client.Observer.get_by_uuid ~rpc ~session_id ~uuid in Client.Observer.destroy ~rpc ~session_id ~self end + +module VM_group = struct + let create printer rpc session_id params = + let name_label = List.assoc "name-label" params in + let name_description = + List.assoc_opt "name-description" params |> Option.value ~default:"" + in + let placement = + Record_util.vm_placement_policy_of_string (List.assoc "placement" params) + in + let ref = + Client.VM_group.create ~rpc ~session_id ~name_label ~name_description + ~placement + in + let uuid = Client.VM_group.get_uuid ~rpc ~session_id ~self:ref in + printer (Cli_printer.PList [uuid]) + + let destroy _printer rpc session_id params = + let ref = + Client.VM_group.get_by_uuid ~rpc ~session_id + ~uuid:(List.assoc "uuid" params) + in + Client.VM_group.destroy ~rpc ~session_id ~self:ref +end diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml index 5332c2aee16..38f5af414e4 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -1188,3 +1188,18 @@ let update_sync_frequency_of_string s = `weekly | _ -> raise (Record_failure ("Expected 'daily', 'weekly', got " ^ s)) + +let vm_placement_policy_to_string = function + | `normal -> + "normal" + | `anti_affinity -> + "anti-affinity" + +let vm_placement_policy_of_string a = + match String.lowercase_ascii a with + | "normal" -> + `normal + | "anti-affinity" -> + `anti_affinity + | s -> + raise (Record_failure ("Invalid VM placement policy, got " ^ s)) diff --git a/ocaml/xapi-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index 6648d755876..3a42bc15e66 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -2504,6 +2504,21 @@ let vm_record rpc session_id vm = ~value:(Client.VM_appliance.get_by_uuid ~rpc ~session_id ~uuid:x) ) () + ; make_field ~name:"groups" + ~get:(fun () -> get_uuids_from_refs (x ()).API.vM_groups) + ~set:(fun x -> + if x = "" then + Client.VM.set_groups ~rpc ~session_id ~self:vm ~value:[] + else + let value = + get_words ',' x + |> List.map (fun uuid -> + Client.VM_group.get_by_uuid ~rpc ~session_id ~uuid + ) + in + Client.VM.set_groups ~rpc ~session_id ~self:vm ~value + ) + () ; make_field ~name:"snapshot-schedule" ~get:(fun () -> get_uuid_from_ref (x ()).API.vM_snapshot_schedule) ~set:(fun x -> @@ -4070,6 +4085,55 @@ let vm_appliance_record rpc session_id vm_appliance = ] } +let vm_group_record rpc session_id vm_group = + let _ref = ref vm_group in + let empty_record = + ToGet (fun () -> Client.VM_group.get_record ~rpc ~session_id ~self:!_ref) + in + let record = ref empty_record in + let x () = lzy_get record in + { + setref= + (fun r -> + _ref := r ; + record := empty_record + ) + ; setrefrec= + (fun (a, b) -> + _ref := a ; + record := Got b + ) + ; record= x + ; getref= (fun () -> !_ref) + ; fields= + [ + make_field ~name:"uuid" ~get:(fun () -> (x ()).API.vM_group_uuid) () + ; make_field ~name:"name-label" + ~get:(fun () -> (x ()).API.vM_group_name_label) + ~set:(fun value -> + Client.VM_group.set_name_label ~rpc ~session_id ~self:!_ref ~value + ) + () + ; make_field ~name:"name-description" + ~get:(fun () -> (x ()).API.vM_group_name_description) + ~set:(fun value -> + Client.VM_group.set_name_description ~rpc ~session_id ~self:!_ref + ~value + ) + () + ; make_field ~name:"placement" + ~get:(fun () -> + Record_util.vm_placement_policy_to_string + (x ()).API.vM_group_placement + ) + () + ; make_field ~name:"vm-uuids" + ~get:(fun () -> get_uuids_from_refs (x ()).API.vM_group_VMs) + ~get_set:(fun () -> List.map get_uuid_from_ref (x ()).API.vM_group_VMs) + () + ] + } + let dr_task_record rpc session_id dr_task = let _ref = ref dr_task in let empty_record = diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 43fff504a3d..562d95f62ae 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1299,3 +1299,5 @@ let telemetry_next_collection_too_late = "TELEMETRY_NEXT_COLLECTION_TOO_LATE" (* FIPS/CC_PREPARATIONS *) let illegal_in_fips_mode = "ILLEGAL_IN_FIPS_MODE" + +let too_many_groups = "TOO_MANY_GROUPS" diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index b7209ec323e..182c587925e 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -39,6 +39,7 @@ module Actions = struct module VMPP = Xapi_vmpp module VMSS = Xapi_vmss module VM_appliance = Xapi_vm_appliance + module VM_group = Xapi_vm_group module DR_task = Xapi_dr_task module LVHD = struct end diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index b2eb86c805d..3c774cbe9ba 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -416,6 +416,17 @@ functor Ref.string_of vm_appliance with _ -> "invalid" + let vm_group_uuid ~__context vm_group = + try + if Pool_role.is_master () then + let name = Db.VM_group.get_name_label ~__context ~self:vm_group in + Printf.sprintf "%s%s" + (Db.VM_group.get_uuid ~__context ~self:vm_group) + (add_brackets name) + else + Ref.string_of vm_group + with _ -> "invalid" + let sr_uuid ~__context sr = try if Pool_role.is_master () then @@ -2996,6 +3007,12 @@ functor (vm_appliance_uuid ~__context value) ; Local.VM.set_appliance ~__context ~self ~value + let set_groups ~__context ~self ~value = + info "VM.set_groups : self = '%s'; value = [ %s ]" + (vm_uuid ~__context self) + (String.concat "; " (List.map (vm_group_uuid ~__context) value)) ; + Local.VM.set_groups ~__context ~self ~value + let import_convert ~__context ~_type ~username ~password ~sr ~remote_config = info "VM.import_convert: type = '%s'; remote_config = '%s;'" _type @@ -6511,6 +6528,21 @@ functor ) end + module VM_group = struct + let create ~__context ~name_label ~name_description ~placement = + info + "VM_group.create: name_label = '%s'; name_description = '%s'; \ + placement = '%s'" + name_label name_description + (Record_util.vm_placement_policy_to_string placement) ; + Local.VM_group.create ~__context ~name_label ~name_description + ~placement + + let destroy ~__context ~self = + info "VM_group.destroy: self = '%s'" (vm_group_uuid ~__context self) ; + Local.VM_group.destroy ~__context ~self + end + module Observer = struct module RefSet = Set.Make (struct type t = [`host] Ref.t diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index e0de06045e1..767fd18a1b0 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1444,6 +1444,11 @@ let set_appliance ~__context ~self ~value = (* Update the VM's allowed operations - this will update the new appliance's operations, if valid. *) update_allowed_operations ~__context ~self +let set_groups ~__context ~self ~value = + if List.length value > 1 then + raise Api_errors.(Server_error (Api_errors.too_many_groups, [])) ; + Db.VM.set_groups ~__context ~self ~value + let import_convert ~__context ~_type ~username ~password ~sr ~remote_config = let open Vpx in let print_jobInstance (j : Vpx.jobInstance) = diff --git a/ocaml/xapi/xapi_vm.mli b/ocaml/xapi/xapi_vm.mli index c349ff8dcb0..a7fbfb62570 100644 --- a/ocaml/xapi/xapi_vm.mli +++ b/ocaml/xapi/xapi_vm.mli @@ -372,6 +372,9 @@ val set_suspend_VDI : val set_appliance : __context:Context.t -> self:API.ref_VM -> value:API.ref_VM_appliance -> unit +val set_groups : + __context:Context.t -> self:API.ref_VM -> value:API.ref_VM_group_set -> unit + val import_convert : __context:Context.t -> _type:string diff --git a/ocaml/xapi/xapi_vm_group.ml b/ocaml/xapi/xapi_vm_group.ml new file mode 100644 index 00000000000..d475da32542 --- /dev/null +++ b/ocaml/xapi/xapi_vm_group.ml @@ -0,0 +1,24 @@ +(* + * Copyright (c) Cloud Software Group, 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. + *) + +module D = Debug.Make (struct let name = "xapi_vm_group" end) + +let create ~__context ~name_label ~name_description ~placement = + let uuid = Uuidx.make () in + let ref = Ref.make () in + Db.VM_group.create ~__context ~ref ~uuid:(Uuidx.to_string uuid) ~name_label + ~name_description ~placement ; + ref + +let destroy ~__context ~self = Db.VM_group.destroy ~__context ~self diff --git a/ocaml/xapi/xapi_vm_group.mli b/ocaml/xapi/xapi_vm_group.mli new file mode 100644 index 00000000000..5ea43acc204 --- /dev/null +++ b/ocaml/xapi/xapi_vm_group.mli @@ -0,0 +1,22 @@ +(* + * Copyright (c) Cloud Software Group, 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. + *) + +val create : + __context:Context.t + -> name_label:string + -> name_description:string + -> placement:API.placement_policy + -> [`VM_group] Ref.t + +val destroy : __context:Context.t -> self:[`VM_group] Ref.t -> unit diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index 538dda7bb01..b8a382e318e 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -117,7 +117,9 @@ let set_is_a_template ~__context ~self ~value = ) |> List.rev |> List.iter (fun p -> Db.PVS_proxy.destroy ~__context ~self:p) ; - (* delete the vm metrics associated with the vm if it exists, when we templat'ize it *) + (* Remove from any VM groups when we templatize it *) + Db.VM.set_groups ~__context ~self ~value:[] ; + (* Delete the vm metrics associated with the vm if it exists, when we templatize it *) finally (fun () -> Db.VM_metrics.destroy ~__context ~self:m) (fun () -> Db.VM.set_metrics ~__context ~self ~value:Ref.null) diff --git a/ocaml/xe-cli/bash-completion b/ocaml/xe-cli/bash-completion index ce9d5ae5f11..e697d777e37 100644 --- a/ocaml/xe-cli/bash-completion +++ b/ocaml/xe-cli/bash-completion @@ -114,6 +114,7 @@ _xe() pvs-site-*|\ sdn-controller-*|\ network-sriov-*|\ + vm-group-*|\ cluster-host-*) # Chop off at the second '-' and append 'list' cmd="$(echo ${OLDSTYLE_WORDS[1]} | cut -d- -f1-2)-list";; @@ -387,6 +388,12 @@ _xe() return 0 ;; + placement) # for vm-group-create + IFS=$'\n,' + set_completions 'normal,anti-affinity' "$value" + return 0 + ;; + *) snd=`echo ${param} | gawk -F- '{print $NF}'` fst=`echo ${param} | gawk -F- '{printf "%s", $1; for (i=2; i Date: Thu, 18 Apr 2024 15:01:03 +0800 Subject: [PATCH 02/44] UT - CP-47655: [Toolstack] - Associate/disassociate VM to/from anti-affinity group UT - CP-47304: [Toolstack] - Add data model for anti-affinity group Signed-off-by: Bengang Yuan --- ocaml/tests/common/test_common.ml | 7 ++++ ocaml/tests/suite_alcotest.ml | 1 + ocaml/tests/test_vm_group.ml | 55 +++++++++++++++++++++++++++++++ 3 files changed, 63 insertions(+) create mode 100644 ocaml/tests/test_vm_group.ml diff --git a/ocaml/tests/common/test_common.ml b/ocaml/tests/common/test_common.ml index d1433868fdc..cb7b24af99e 100644 --- a/ocaml/tests/common/test_common.ml +++ b/ocaml/tests/common/test_common.ml @@ -674,3 +674,10 @@ let make_observer ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ()) Db.Observer.create ~__context ~ref ~uuid ~name_label ~name_description ~hosts ~attributes ~endpoints ~components ~enabled ; ref + +let make_vm_group ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ()) + ?(name_label = "vm_group") ?(name_description = "") ?(placement = `normal) + () = + Db.VM_group.create ~__context ~ref ~uuid ~name_label ~name_description + ~placement ; + ref diff --git a/ocaml/tests/suite_alcotest.ml b/ocaml/tests/suite_alcotest.ml index 21a637d5ea7..be73d7cef06 100644 --- a/ocaml/tests/suite_alcotest.ml +++ b/ocaml/tests/suite_alcotest.ml @@ -46,6 +46,7 @@ let () = ; ("Test_storage_migrate_state", Test_storage_migrate_state.test) ; ("Test_bios_strings", Test_bios_strings.test) ; ("Test_certificates", Test_certificates.test) + ; ("Test_vm_group", Test_vm_group.test) ] @ Test_guest_agent.tests @ Test_nm.tests diff --git a/ocaml/tests/test_vm_group.ml b/ocaml/tests/test_vm_group.ml new file mode 100644 index 00000000000..910711f9646 --- /dev/null +++ b/ocaml/tests/test_vm_group.ml @@ -0,0 +1,55 @@ +(* + * Copyright (c) Cloud Software Group, 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. + *) + +module T = Test_common + +let test_associate_vm_with_vm_group () = + let __context = T.make_test_database () in + let rpc, session_id = Test_common.make_client_params ~__context in + let vm1 = T.make_vm ~__context () in + let vm2 = T.make_vm ~__context () in + let vm3 = T.make_vm ~__context () in + let vm_group = T.make_vm_group ~__context ~placement:`anti_affinity () in + Client.Client.VM.set_groups ~rpc ~session_id ~self:vm1 ~value:[vm_group] ; + Client.Client.VM.set_groups ~rpc ~session_id ~self:vm2 ~value:[vm_group] ; + Client.Client.VM.set_groups ~rpc ~session_id ~self:vm3 ~value:[vm_group] ; + let vms = Db.VM_group.get_VMs ~__context ~self:vm_group in + let extract_vm_strings vms = + List.sort String.compare (List.map Ref.string_of vms) + in + Alcotest.(check (slist string String.compare)) + "check VMs are in the group" (extract_vm_strings vms) + (extract_vm_strings [vm1; vm2; vm3]) + +let test_vm_can_only_belong_to_one_group () = + let __context = T.make_test_database () in + let rpc, session_id = Test_common.make_client_params ~__context in + let vm = T.make_vm ~__context () in + let vm_group1 = T.make_vm_group ~__context ~placement:`anti_affinity () in + let vm_group2 = T.make_vm_group ~__context ~placement:`anti_affinity () in + Alcotest.check_raises "should fail" + (Api_errors.Server_error (Api_errors.too_many_groups, [])) + (fun () -> + Client.Client.VM.set_groups ~rpc ~session_id ~self:vm + ~value:[vm_group1; vm_group2] + ) + +let test = + [ + ("test_associate_vm_with_vm_group", `Quick, test_associate_vm_with_vm_group) + ; ( "test_vm_can_only_belong_to_one_group" + , `Quick + , test_vm_can_only_belong_to_one_group + ) + ] From 2c920ed032c5bd8073996dab2f055f3af2122622 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Fri, 19 Apr 2024 17:55:31 +0800 Subject: [PATCH 03/44] CA-391880: Update related field 'groups' of VM when destroying VM group. In VM anti-affinity datamodel PR (https://github.com/xapi-project/xen-api/pull/5573), there is many-many relation between VMs and VM groups. When changing the VM.groups manually, the VM_group.VMs will be updated automatically. But when removing a VM group, the VM.groups will not be updated automatically. This commit aims to update VM.groups for all VMs in a VM group when it is being removed. Signed-off-by: Bengang Yuan --- ocaml/xapi/xapi_vm_group.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/ocaml/xapi/xapi_vm_group.ml b/ocaml/xapi/xapi_vm_group.ml index d475da32542..0d77e9d3f51 100644 --- a/ocaml/xapi/xapi_vm_group.ml +++ b/ocaml/xapi/xapi_vm_group.ml @@ -21,4 +21,8 @@ let create ~__context ~name_label ~name_description ~placement = ~name_description ~placement ; ref -let destroy ~__context ~self = Db.VM_group.destroy ~__context ~self +let destroy ~__context ~self = + List.iter + (fun vm -> Db.VM.remove_groups ~__context ~self:vm ~value:self) + (Db.VM_group.get_VMs ~__context ~self) ; + Db.VM_group.destroy ~__context ~self From 1425790608f8bdbe5da47ac4d66201b3c8c5f384 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Thu, 25 Apr 2024 15:36:29 +0800 Subject: [PATCH 04/44] CP-47302: VM start with anti-affinity VM in an anti-affinity group will choose a host based on the following steps: 1. If the VM is associated with an anti-affinity group, compute the number of VMs associated with this anti-affinity group for each host. 2. Group these hosts based on the VM's count. The hosts in one group have the same number of VMs in one anti-affinity group. Sort all the host groups ascending based on the VM's count. 3. If a host is the affinity host of this VM, it will be treated as a single host group and be put on the head of the group list. 4. Choose a host randomly which the VM can run on it from each group. Signed-off-by: Bengang Yuan --- ocaml/xapi/xapi_vm_helpers.ml | 105 ++++++++++++++++++++++++++++++++-- 1 file changed, 100 insertions(+), 5 deletions(-) diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index b8a382e318e..ec6868db0e4 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -35,6 +35,12 @@ module SRSet = Set.Make (struct let compare = Stdlib.compare end) +module RefMap = Map.Make (struct + type t = [`host] Ref.t + + let compare = Ref.compare +end) + let compute_memory_overhead ~__context ~vm = let vm_record = Db.VM.get_record ~__context ~self:vm in Memory_check.vm_compute_memory_overhead ~vm_record @@ -931,6 +937,20 @@ let vm_can_run_on_host ~__context ~vm ~snapshot ~do_memory_check host = && host_evacuate_in_progress with _ -> false +let vm_has_anti_affinity ~__context ~vm = + List.find_opt + (fun g -> Db.VM_group.get_placement ~__context ~self:g = `anti_affinity) + (Db.VM.get_groups ~__context ~self:vm) + |> Option.map (fun group -> + debug + "The VM (uuid %s) is associated with an anti-affinity group (uuid: \ + %s, name: %s)" + (Db.VM.get_uuid ~__context ~self:vm) + (Db.VM_group.get_uuid ~__context ~self:group) + (Db.VM_group.get_name_label ~__context ~self:group) ; + `AntiAffinity group + ) + let vm_has_vgpu ~__context ~vm = match Db.VM.get_VGPUs ~__context ~self:vm with | [] -> @@ -950,7 +970,11 @@ let vm_has_sriov ~__context ~vm = let ( >>= ) opt f = match opt with Some _ as v -> v | None -> f let get_group_key ~__context ~vm = - match None >>= vm_has_vgpu ~__context ~vm >>= vm_has_sriov ~__context ~vm with + match + vm_has_anti_affinity ~__context ~vm + >>= vm_has_vgpu ~__context ~vm + >>= vm_has_sriov ~__context ~vm + with | Some x -> x | None -> @@ -996,12 +1020,81 @@ let rank_hosts_by_best_vgpu ~__context vgpu visible_hosts = 0L ) hosts - |> List.map (fun g -> List.map (fun (h, _) -> h) g) + |> List.map (fun g -> List.map fst g) + +(* Group all hosts to 2 parts: + 1. A list of affinity host (only one host). + 2. A list of lists, each list contains hosts with the same number of + running VM in that anti-affinity group. + These lists are sorted by VM's count. + Combine these lists into one list. The list is like below: + [ [host1] (affinity host) + , [host2, host3] (no VM running) + , [host4, host5] (one VM running) + , [host6, host7] (more VMs running) + , ... + ] +*) +let rank_hosts_by_placement ~__context ~vm ~group = + let affinity_host = + match Db.VM.get_affinity ~__context ~self:vm with + | ref when Db.is_valid_ref __context ref -> + [ref] + | _ -> + [] + in + let sorted_hosts = + let host_without_affinity_host = + Db.Host.get_all ~__context + |> List.filter (fun host -> not (List.mem host affinity_host)) + in + let host_of_vm vm = + let vm_rec = Db.VM.get_record ~__context ~self:vm in + (* 1. When a VM starts migrating, it's 'scheduled_to_be_resident_on' will be set, + while its 'resident_on' is not cleared. In this case, + 'scheduled_to_be_resident_on' should be treated as its running host. + 2. For paused VM, its 'resident_on' has value, but it will not be considered + while computing the amount of VMs. *) + match + ( vm_rec.API.vM_scheduled_to_be_resident_on + , vm_rec.API.vM_resident_on + , vm_rec.API.vM_power_state + ) + with + | sh, _, _ when sh <> Ref.null -> + Some sh + | _, h, `Running when h <> Ref.null -> + Some h + | _ -> + None + in + let host_map = + Db.VM_group.get_VMs ~__context ~self:group + |> List.fold_left + (fun m vm -> + match host_of_vm vm with + | Some h -> + RefMap.update h + (fun c -> Option.(value ~default:0 c |> succ |> some)) + m + | None -> + m + ) + RefMap.empty + in + host_without_affinity_host + |> Helpers.group_by ~ordering:`ascending (fun h -> + RefMap.find_opt h host_map |> Option.value ~default:0 + ) + |> List.map (fun g -> List.map fst g) + in + affinity_host :: sorted_hosts |> List.filter (( <> ) []) (* Selects a single host from the set of all hosts on which the given [vm] can boot. Raises [Api_errors.no_hosts_available] if no such host exists. - 1.Take Vgpu or Network SR-IOV as a group_key for group all hosts into host list list - 2.helper function's order determine the priority of resources,now vgpu has higher priority than Network SR-IOV + 1.Take anti-affinity, or VGPU, or Network SR-IOV as a group_key for group all hosts into host list list + 2.helper function's order determine the priority of resources,now anti-affinity has the highest priority, + VGPU is the second, Network SR-IOV is the lowest 3.If no key found in VM,then host_lists will be [all_hosts] *) let choose_host_for_vm_no_wlb ~__context ~vm ~snapshot = let validate_host = @@ -1013,6 +1106,8 @@ let choose_host_for_vm_no_wlb ~__context ~vm ~snapshot = match group_key with | `Other -> [all_hosts] + | `AntiAffinity group -> + rank_hosts_by_placement ~__context ~vm ~group | `VGPU vgpu -> let can_host_vm ~__context host vm = try @@ -1027,7 +1122,7 @@ let choose_host_for_vm_no_wlb ~__context ~vm ~snapshot = let host_group = Xapi_network_sriov_helpers.group_hosts_by_best_sriov ~__context ~network - |> List.map (fun g -> List.map (fun (h, _) -> h) g) + |> List.map (fun g -> List.map fst g) in if host_group <> [] then host_group From 0de00bad675cb99f90c835fafca8556ef93ff92d Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Thu, 25 Apr 2024 15:36:39 +0800 Subject: [PATCH 05/44] CP-47302: UT for VM start with anti-affinity Signed-off-by: Bengang Yuan --- ocaml/tests/test_vm_helpers.ml | 515 ++++++++++++++++++++++++++++++++- 1 file changed, 509 insertions(+), 6 deletions(-) diff --git a/ocaml/tests/test_vm_helpers.ml b/ocaml/tests/test_vm_helpers.ml index bdd8dc061d8..f62c5145971 100644 --- a/ocaml/tests/test_vm_helpers.ml +++ b/ocaml/tests/test_vm_helpers.ml @@ -159,7 +159,7 @@ let rec assert_equivalent expected_grouping actual_grouping = assert_host_groups_equal e g ; assert_equivalent es gs -let assert_host_groups_equal_for_vgpu g g' = +let assert_host_groups_equal g g' = match g' with | [] -> () @@ -170,7 +170,7 @@ let assert_host_groups_equal_for_vgpu g g' = Alcotest.(check (slist string String.compare)) "check host strings" (extract_host_strings g) (extract_host_strings g') -let rec assert_equivalent_for_vgpu expected_grouping actual_grouping = +let rec assert_equivalent_for_grouping expected_grouping actual_grouping = match (expected_grouping, actual_grouping) with | [], [] -> () @@ -181,13 +181,13 @@ let rec assert_equivalent_for_vgpu expected_grouping actual_grouping = Alcotest.fail (Printf.sprintf "%d fewer groups than expected." (List.length xx)) | e :: es, g :: gs -> - assert_host_groups_equal_for_vgpu e g ; - assert_equivalent_for_vgpu es gs + assert_host_groups_equal e g ; + assert_equivalent_for_grouping es gs let assert_grouping ~__context gpu_group ~visible_hosts vgpu_type g = let vgpu = VGPU_T.make_vgpu ~__context ~gPU_group:gpu_group vgpu_type in let host_lists = rank_hosts_by_best_vgpu ~__context vgpu visible_hosts in - assert_equivalent_for_vgpu g host_lists + assert_equivalent_for_grouping g host_lists let check_expectations ~__context gpu_group visible_hosts vgpu_type expected_grouping = @@ -524,6 +524,44 @@ let test_group_hosts_netsriov_with_allocated () = "Test-failure: Unexpected number of sriov network in test" ) +let on_pool_of_anti_affinity placement + (f : Context.t -> API.ref_host -> API.ref_host -> API.ref_host -> 'a) = + let __context = T.make_test_database () in + let h1 = + match Db.Host.get_all ~__context with + | h :: _ -> + h + | [] -> + T.make_host ~__context () + in + (* Make two more hosts *) + let h2 = T.make_host ~__context () in + let h3 = T.make_host ~__context () in + let g = T.make_vm_group ~__context ~placement () in + f __context h1 h2 h3 g + +let test_get_group_key_anti_affinity () = + on_pool_of_anti_affinity `anti_affinity (fun __context _ _ _ g -> + let vm = T.make_vm ~__context () in + Db.VM.set_groups ~__context ~self:vm ~value:[g] ; + match Xapi_vm_helpers.get_group_key ~__context ~vm with + | `AntiAffinity _ -> + () + | _ -> + Alcotest.fail "Test-failure: Unexpected Group Key in test" + ) + +let test_get_group_key_normal_group () = + on_pool_of_anti_affinity `normal (fun __context _ _ _ g -> + let vm = T.make_vm ~__context () in + Db.VM.set_groups ~__context ~self:vm ~value:[g] ; + match Xapi_vm_helpers.get_group_key ~__context ~vm with + | `Other -> + () + | _ -> + Alcotest.fail "Test-failure: Unexpected Group Key in test" + ) + let test_get_group_key_vgpu () = on_pool_of_intel_i350 (fun __context _ _ _ -> let group = List.hd (Db.GPU_group.get_all ~__context) in @@ -573,6 +611,461 @@ let test_get_group_key_vgpu_and_netsriov () = Alcotest.fail "Test-failure: Unexpected Group Key in test" ) +let test_get_group_key_anti_affinity_and_vgpu_and_netsriov () = + on_pool_of_intel_i350 (fun __context _ _ _ -> + let group = + match Db.GPU_group.get_all ~__context with + | g :: _ -> + g + | [] -> + Alcotest.fail "Can not find any GPU_group" + in + let vm = make_vm_with_vgpu_in_group ~__context VGPU_T.k100 group in + let sriov_network = + List.find + (fun network -> + Xapi_network_sriov_helpers.is_sriov_network ~__context ~self:network + ) + (Db.Network.get_all ~__context) + in + let (_ : API.ref_VIF) = + T.make_vif ~__context ~vM:vm ~network:sriov_network () + in + let anti_affinity_group = + T.make_vm_group ~__context ~placement:`anti_affinity () + in + Db.VM.set_groups ~__context ~self:vm ~value:[anti_affinity_group] ; + match Xapi_vm_helpers.get_group_key ~__context ~vm with + | `AntiAffinity _ -> + () + | _ -> + Alcotest.fail "Test-failure: Unexpected Group Key in test" + ) + +module VMAntiAffinityRankedGrpTest = struct + type vm_state = Running | Starting | Migrating | Suspended | Paused | Halted + + type vm_info = { + name: string option + ; host: string option + ; group: string option + ; state: vm_state + } + + type test_case = { + description: string + ; vm_to_start: vm_info + ; other_vms: vm_info list + ; hosts: string option list + ; affinity_host: string option + ; expected: string option list list + } + + let vm_to_start = Some "vm" + + let vm1 = Some "vm1" + + let vm2 = Some "vm2" + + let vm3 = Some "vm3" + + let vm4 = Some "vm4" + + let vm5 = Some "vm5" + + let vm6 = Some "vm6" + + let h1 = Some "h1" + + let h2 = Some "h2" + + let h3 = Some "h3" + + let anti_affinity = Some "anti-affinity" + + let other_group = Some "other-group" + + let test_cases = + [ + { + description= "No other VM" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= [] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1; h2; h3]] + } + ; { + description= "VMs not in group" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h2; group= None; state= Running} + ; {name= vm2; host= h3; group= None; state= Running} + ; {name= vm3; host= h3; group= None; state= Running} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1; h2; h3]] + } + ; { + description= "VMs in other group" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h2; group= other_group; state= Running} + ; {name= vm2; host= h3; group= other_group; state= Running} + ; {name= vm3; host= h3; group= other_group; state= Running} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1; h2; h3]] + } + ; { + description= "3 running VMs (h1(0) h2(1) h3(2))" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h2; group= anti_affinity; state= Running} + ; {name= vm2; host= h3; group= anti_affinity; state= Running} + ; {name= vm3; host= h3; group= anti_affinity; state= Running} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1]; [h2]; [h3]] + } + ; { + description= "3 running VMs (h1(1) h2(1) h3(1))" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h1; group= anti_affinity; state= Running} + ; {name= vm2; host= h2; group= anti_affinity; state= Running} + ; {name= vm3; host= h3; group= anti_affinity; state= Running} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1; h2; h3]] + } + ; { + description= "3 running VMs (h1(0) h2(0) h3(3))" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h3; group= anti_affinity; state= Running} + ; {name= vm2; host= h3; group= anti_affinity; state= Running} + ; {name= vm3; host= h3; group= anti_affinity; state= Running} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1; h2]; [h3]] + } + ; { + description= "3 starting VMs (h1(0) h2(1) h3(2))" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h2; group= anti_affinity; state= Starting} + ; {name= vm2; host= h3; group= anti_affinity; state= Starting} + ; {name= vm3; host= h3; group= anti_affinity; state= Starting} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1]; [h2]; [h3]] + } + ; { + description= "3 starting VMs (h1(1) h2(1) h3(1))" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h1; group= anti_affinity; state= Starting} + ; {name= vm2; host= h2; group= anti_affinity; state= Starting} + ; {name= vm3; host= h3; group= anti_affinity; state= Starting} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1; h2; h3]] + } + ; { + description= "3 starting VMs (h1(0) h2(0) h3(3))" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h3; group= anti_affinity; state= Starting} + ; {name= vm2; host= h3; group= anti_affinity; state= Starting} + ; {name= vm3; host= h3; group= anti_affinity; state= Starting} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1; h2]; [h3]] + } + ; { + description= "3 migrating VMs (h1(0) h2(1) h3(2))" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h2; group= anti_affinity; state= Migrating} + ; {name= vm2; host= h3; group= anti_affinity; state= Migrating} + ; {name= vm3; host= h3; group= anti_affinity; state= Migrating} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1]; [h2]; [h3]] + } + ; { + description= "3 migrating VMs (h1(0) h2(0) h3(3))" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h3; group= anti_affinity; state= Migrating} + ; {name= vm2; host= h3; group= anti_affinity; state= Migrating} + ; {name= vm3; host= h3; group= anti_affinity; state= Migrating} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1; h2]; [h3]] + } + ; { + description= "3 stopped VMs" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= None; group= anti_affinity; state= Halted} + ; {name= vm2; host= None; group= anti_affinity; state= Halted} + ; {name= vm3; host= None; group= anti_affinity; state= Halted} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1; h2; h3]] + } + ; { + description= "3 suspended VMs" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= None; group= anti_affinity; state= Suspended} + ; {name= vm2; host= None; group= anti_affinity; state= Suspended} + ; {name= vm3; host= None; group= anti_affinity; state= Suspended} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1; h2; h3]] + } + ; { + description= "3 paused VMs (h1(0) h2(1) h3(2))" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h2; group= anti_affinity; state= Paused} + ; {name= vm2; host= h3; group= anti_affinity; state= Paused} + ; {name= vm3; host= h3; group= anti_affinity; state= Paused} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1; h2; h3]] + } + ; { + description= "3 running VMs with affinity-host" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h1; group= anti_affinity; state= Running} + ; {name= vm2; host= h2; group= anti_affinity; state= Running} + ; {name= vm3; host= h3; group= anti_affinity; state= Running} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= h1 + ; expected= [[h1]; [h2; h3]] + } + ; { + description= "6 running VMs (h1(1) h2(2) h3(3))" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h1; group= anti_affinity; state= Running} + ; {name= vm2; host= h2; group= anti_affinity; state= Running} + ; {name= vm3; host= h2; group= anti_affinity; state= Running} + ; {name= vm4; host= h3; group= anti_affinity; state= Running} + ; {name= vm5; host= h3; group= anti_affinity; state= Running} + ; {name= vm6; host= h3; group= anti_affinity; state= Running} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1]; [h2]; [h3]] + } + ; { + description= "6 running VMs (h1(2) h2(2) h3(2))" + ; vm_to_start= + {name= vm_to_start; host= None; group= anti_affinity; state= Halted} + ; other_vms= + [ + {name= vm1; host= h1; group= anti_affinity; state= Running} + ; {name= vm2; host= h1; group= anti_affinity; state= Running} + ; {name= vm3; host= h2; group= anti_affinity; state= Running} + ; {name= vm4; host= h2; group= anti_affinity; state= Running} + ; {name= vm5; host= h3; group= anti_affinity; state= Running} + ; {name= vm6; host= h3; group= anti_affinity; state= Running} + ] + ; hosts= [h1; h2; h3] + ; affinity_host= None + ; expected= [[h1; h2; h3]] + } + ] + + let make_hosts ~__context ~hosts = + match hosts with + | fst :: others -> + let host1 = + match Db.Host.get_all ~__context with + | h :: _ -> + h + | _ -> + T.make_host ~__context () + in + Db.Host.set_name_label ~__context ~self:host1 ~value:(Option.get fst) ; + List.iter + (fun h -> + let _ = T.make_host ~__context ~name_label:(Option.get h) () in + () + ) + others + | [] -> + () + + let make_vm_based_on_vm_info ~__context ~vm_info = + let vm = + T.make_vm ~__context + ~name_label:(Option.value vm_info.name ~default:(Option.get vm_to_start)) + () + in + ( match vm_info.group with + | None -> + () + | Some group_name -> + let group = + match Db.VM_group.get_by_name_label ~__context ~label:group_name with + | g :: _ -> + g + | [] -> + T.make_vm_group ~__context ~placement:`anti_affinity + ~name_label:group_name () + in + Db.VM.set_groups ~__context ~self:vm ~value:[group] + ) ; + ( match vm_info.host with + | None -> + () + | Some host_name -> ( + let host = + match Db.Host.get_by_name_label ~__context ~label:host_name with + | h :: _ -> + h + | [] -> + Alcotest.fail "Can not find any host by name_label" + in + match vm_info.state with + | Running -> + Db.VM.set_power_state ~__context ~self:vm ~value:`Running ; + Db.VM.set_resident_on ~__context ~self:vm ~value:host + | Starting -> + Db.VM.set_power_state ~__context ~self:vm ~value:`Halted ; + Db.VM.set_scheduled_to_be_resident_on ~__context ~self:vm + ~value:host + | Migrating -> + Db.VM.set_power_state ~__context ~self:vm ~value:`Running ; + Db.VM.set_scheduled_to_be_resident_on ~__context ~self:vm + ~value:host ; + let other_hosts = + Db.Host.get_all ~__context + |> List.filter (fun h -> + Db.Host.get_name_label ~__context ~self:h <> host_name + ) + in + let other = match other_hosts with h :: _ -> h | [] -> Ref.null in + Db.VM.set_resident_on ~__context ~self:vm ~value:other + | Suspended -> + Db.VM.set_power_state ~__context ~self:vm ~value:`Suspended + | Paused -> + Db.VM.set_power_state ~__context ~self:vm ~value:`Paused ; + Db.VM.set_resident_on ~__context ~self:vm ~value:host + | Halted -> + Db.VM.set_power_state ~__context ~self:vm ~value:`Halted + ) + ) ; + vm + + let check_anti_affinity_grouping ~__context ~vm ~group expected_grouping = + let host_lists = rank_hosts_by_placement ~__context ~vm ~group in + assert_equivalent_for_grouping expected_grouping host_lists + + let test {vm_to_start; other_vms; hosts; affinity_host; expected; _} () = + let __context = T.make_test_database () in + make_hosts ~__context ~hosts ; + let vm = make_vm_based_on_vm_info ~__context ~vm_info:vm_to_start in + let _ = + List.map + (fun vm -> make_vm_based_on_vm_info ~__context ~vm_info:vm) + other_vms + in + Db.VM.set_affinity ~__context ~self:vm + ~value: + ( match affinity_host with + | None -> + Ref.null + | Some host_name -> ( + match Db.Host.get_by_name_label ~__context ~label:host_name with + | h :: _ -> + h + | [] -> + Alcotest.fail "Can not find any host by name_label" + ) + ) ; + let group = + match Db.VM.get_groups ~__context ~self:vm with + | g :: _ -> + g + | [] -> + Alcotest.fail "The VM is not associated with any group" + in + check_anti_affinity_grouping ~__context ~vm ~group + (List.map + (fun list -> + List.map + (fun h -> + match + Db.Host.get_by_name_label ~__context ~label:(Option.get h) + with + | h :: _ -> + h + | [] -> + Alcotest.fail "Can not find any host by name_label" + ) + list + ) + expected + ) + + let generate_tests case = (case.description, `Quick, test case) + + let tests = List.map generate_tests test_cases +end + let test = [ ("test_gpus_available_succeeds", `Quick, test_gpus_available_succeeds) @@ -612,14 +1105,24 @@ let test = , `Quick , test_group_hosts_netsriov_with_allocated ) + ; ( "test_get_group_key_anti_affinity" + , `Quick + , test_get_group_key_anti_affinity + ) + ; ("test_get_group_key_normal_group", `Quick, test_get_group_key_normal_group) ; ("test_get_group_key_vgpu", `Quick, test_get_group_key_vgpu) ; ("test_get_group_key_netsriov", `Quick, test_get_group_key_netsriov) ; ( "test_get_group_key_vgpu_and_netsriov" , `Quick , test_get_group_key_vgpu_and_netsriov ) + ; ( "test_get_group_key_anti_affinity_and_vgpu_and_netsriov" + , `Quick + , test_get_group_key_anti_affinity_and_vgpu_and_netsriov + ) ] let () = Suite_init.harness_init () ; - Alcotest.run "Test VM Helpers suite" [("Test_vm_helpers", test)] + Alcotest.run "Test VM Helpers suite" + [("Test_vm_helpers", test @ VMAntiAffinityRankedGrpTest.tests)] From 506fb31a7cb1b3889ac08e8061c563bed45e46a2 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Sun, 28 Apr 2024 14:35:29 +0800 Subject: [PATCH 06/44] CA-392177: Keep current group after reverting from snapshot When reverting to a snapshot, "groups" needs to be in `do_not_copy` to reserve the latest value of the VM. Signed-off-by: Bengang Yuan --- ocaml/xapi/xapi_vm_snapshot.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/ocaml/xapi/xapi_vm_snapshot.ml b/ocaml/xapi/xapi_vm_snapshot.ml index b533aef5da4..28c77f920b9 100644 --- a/ocaml/xapi/xapi_vm_snapshot.ml +++ b/ocaml/xapi/xapi_vm_snapshot.ml @@ -383,6 +383,7 @@ let do_not_copy = "snapshots" ; "tags" ; "affinity" + ; "groups" ; (* Current fields should remain to get destroyed during revert process *) "consoles" ; "VBDs" From 69c8aaf1dabdba8d90a37d887dee5cf50f93398e Mon Sep 17 00:00:00 2001 From: Lunfan Zhang Date: Mon, 29 Apr 2024 06:22:59 -0400 Subject: [PATCH 07/44] CP-47656 Anti-affinity feature - resolve cycle dependency issue Resolve dependency cycling issue if we call Xapi_alerts inside pool_features. Error: dependency cycle between modules in _build/default/ocaml/xapi: Xha_statefile -> Sm -> Sm_exec -> Xapi_session -> Pool_features -> Xapi_vm_group_helpers -> Xapi_alert -> Xapi_http -> Xapi_session Signed-off-by: Lunfan Zhang --- ocaml/xapi/pool_features.ml | 81 -------------------- ocaml/xapi/pool_features.mli | 3 - ocaml/xapi/pool_features_helpers.ml | 108 +++++++++++++++++++++++++++ ocaml/xapi/pool_features_helpers.mli | 15 ++++ ocaml/xapi/xapi_host.ml | 4 +- ocaml/xapi/xapi_pool.ml | 2 +- 6 files changed, 126 insertions(+), 87 deletions(-) create mode 100755 ocaml/xapi/pool_features_helpers.ml create mode 100755 ocaml/xapi/pool_features_helpers.mli diff --git a/ocaml/xapi/pool_features.ml b/ocaml/xapi/pool_features.ml index d3a14dd5221..862f11e3004 100644 --- a/ocaml/xapi/pool_features.ml +++ b/ocaml/xapi/pool_features.ml @@ -15,20 +15,14 @@ open Features module D = Debug.Make (struct let name = "pool_features" end) -open D - (* Terminology: - (Feature) flags: The keys in pool.restriction and host.license_params. Strings like "restrict_dmc". - Params: An instance of host.license_params. - Restrictions: A (string * string) list of feature flag to a Boolean string value ("true" or "false"). - Features: Values of type Features.feature. - - Core: Relating to features known by xapi, as define in features.ml. - - Additional: Relating to features provided by v6d beyond the core ones. *) -let all_flags = List.map (fun (k, _) -> k) (to_assoc_list all_features) - let get_pool_features ~__context = let pool = Helpers.get_pool ~__context in of_assoc_list (Db.Pool.get_restrictions ~__context ~self:pool) @@ -43,78 +37,3 @@ let assert_enabled ~__context ~f = (Api_errors.Server_error (Api_errors.license_restriction, [name_of_feature f]) ) - -(* The set of core restrictions of a pool is the intersection of the sets of features - of the individual hosts. *) -let compute_core_features all_host_params = - List.map of_assoc_list all_host_params - |> List.fold_left Xapi_stdext_std.Listext.List.intersect all_features - -(* Find the feature flags in the given license params that are not represented - in the feature type. These are additional flags given to us by v6d. - Assume that their names always start with "restrict_". *) -let find_additional_flags params = - let kvs = - List.filter - (fun (k, _) -> - try String.sub k 0 9 = "restrict_" && not (List.mem k all_flags) - with Invalid_argument _ -> false - ) - params - in - List.map fst kvs - -(* Determine the set of additional features. For each restrict_ flag, - looks for matching flags on all hosts; if one of them is restricted ("true") - or absent, then the feature on the pool level is marked as restricted. *) -let rec compute_additional_restrictions all_host_params = function - | [] -> - [] - | flag :: rest -> - let switches = - List.map - (function - | params -> - if List.mem_assoc flag params then - bool_of_string (List.assoc flag params) - else - true - ) - all_host_params - in - (flag, string_of_bool (List.fold_left ( || ) false switches)) - :: compute_additional_restrictions all_host_params rest - -(* Combine the host-level feature restrictions into pool-level ones, and write - the result to the database. *) -let update_pool_features ~__context = - (* Get information from the database *) - let pool = Helpers.get_pool ~__context in - let old_restrictions = Db.Pool.get_restrictions ~__context ~self:pool in - let all_host_params = - List.map - (fun (_, host_r) -> host_r.API.host_license_params) - (Db.Host.get_all_records ~__context) - in - let master_params = - let master_ref = Db.Pool.get_master ~__context ~self:pool in - Db.Host.get_license_params ~__context ~self:master_ref - in - (* Determine the set of core restrictions *) - let new_core_features = compute_core_features all_host_params in - let new_core_restrictions = to_assoc_list new_core_features in - (* Determine the set of additional restrictions *) - let additional_flags = find_additional_flags master_params in - let new_additional_restrictions = - compute_additional_restrictions all_host_params additional_flags - in - (* The complete set of restrictions is formed by the core feature plus the additional features *) - let new_restrictions = new_additional_restrictions @ new_core_restrictions in - (* Update the DB if the restrictions have changed *) - if new_restrictions <> old_restrictions then ( - let old_core_features = of_assoc_list old_restrictions in - info "Old pool features enabled: %s" (to_compact_string old_core_features) ; - info "New pool features enabled: %s" (to_compact_string new_core_features) ; - Db.Pool.set_restrictions ~__context ~self:pool ~value:new_restrictions ; - Xapi_pool_helpers.apply_guest_agent_config ~__context - ) diff --git a/ocaml/xapi/pool_features.mli b/ocaml/xapi/pool_features.mli index 714c92ca757..9e4cbcef405 100644 --- a/ocaml/xapi/pool_features.mli +++ b/ocaml/xapi/pool_features.mli @@ -20,6 +20,3 @@ val is_enabled : __context:Context.t -> Features.feature -> bool val assert_enabled : __context:Context.t -> f:Features.feature -> unit (** Raise appropriate exception if feature is not enabled. *) - -val update_pool_features : __context:Context.t -> unit -(** Update the pool-level restrictions list in the database. *) diff --git a/ocaml/xapi/pool_features_helpers.ml b/ocaml/xapi/pool_features_helpers.ml new file mode 100755 index 00000000000..a732320271a --- /dev/null +++ b/ocaml/xapi/pool_features_helpers.ml @@ -0,0 +1,108 @@ +(* + * Copyright (C) 2024 Cloud Software Group + * + * 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 Features + +module D = Debug.Make (struct let name = "pool_features_helpers" end) + +open D + +(* + Terminology: + - (Feature) flags: The keys in pool.restriction and host.license_params. Strings like "restrict_dmc". + - Params: An instance of host.license_params. + - Restrictions: A (string * string) list of feature flag to a Boolean string value ("true" or "false"). + - Features: Values of type Features.feature. + - Core: Relating to features known by xapi, as define in features.ml. + - Additional: Relating to features provided by v6d beyond the core ones. +*) + +let all_flags = List.map (fun (k, _) -> k) (to_assoc_list all_features) + +(* The set of core restrictions of a pool is the intersection of the sets of features + of the individual hosts. *) +let compute_core_features all_host_params = + List.map of_assoc_list all_host_params + |> List.fold_left Xapi_stdext_std.Listext.List.intersect all_features + +(* Find the feature flags in the given license params that are not represented + in the feature type. These are additional flags given to us by v6d. + Assume that their names always start with "restrict_". *) +let find_additional_flags params = + let kvs = + List.filter + (fun (k, _) -> + try String.sub k 0 9 = "restrict_" && not (List.mem k all_flags) + with Invalid_argument _ -> false + ) + params + in + List.map fst kvs + +(* Determine the set of additional features. For each restrict_ flag, + looks for matching flags on all hosts; if one of them is restricted ("true") + or absent, then the feature on the pool level is marked as restricted. *) +let rec compute_additional_restrictions all_host_params = function + | [] -> + [] + | flag :: rest -> + let switches = + List.map + (function + | params -> + if List.mem_assoc flag params then + bool_of_string (List.assoc flag params) + else + true + ) + all_host_params + in + (flag, string_of_bool (List.fold_left ( || ) false switches)) + :: compute_additional_restrictions all_host_params rest + +(* Combine the host-level feature restrictions into pool-level ones, and write + the result to the database. *) +let update_pool_features ~__context = + (* Get information from the database *) + let pool = Helpers.get_pool ~__context in + let old_restrictions = Db.Pool.get_restrictions ~__context ~self:pool in + let all_host_params = + List.map + (fun (_, host_r) -> host_r.API.host_license_params) + (Db.Host.get_all_records ~__context) + in + let master_params = + let master_ref = Db.Pool.get_master ~__context ~self:pool in + Db.Host.get_license_params ~__context ~self:master_ref + in + (* Determine the set of core restrictions *) + let new_core_features = compute_core_features all_host_params in + let new_core_restrictions = to_assoc_list new_core_features in + (* Determine the set of additional restrictions *) + let additional_flags = find_additional_flags master_params in + let new_additional_restrictions = + compute_additional_restrictions all_host_params additional_flags + in + (* The complete set of restrictions is formed by the core feature plus the additional features *) + let new_restrictions = new_additional_restrictions @ new_core_restrictions in + (* Update the DB if the restrictions have changed *) + if new_restrictions <> old_restrictions then ( + let old_core_features = of_assoc_list old_restrictions in + info "Old pool features enabled: %s" (to_compact_string old_core_features) ; + info "New pool features enabled: %s" (to_compact_string new_core_features) ; + Db.Pool.set_restrictions ~__context ~self:pool ~value:new_restrictions ; + Xapi_vm_group_helpers.update_vm_placement_alert_when_restriction_change + ~__context ~old_restrictions ~new_restrictions ; + Xapi_pool_helpers.apply_guest_agent_config ~__context + ) diff --git a/ocaml/xapi/pool_features_helpers.mli b/ocaml/xapi/pool_features_helpers.mli new file mode 100755 index 00000000000..1b7c52ff1fe --- /dev/null +++ b/ocaml/xapi/pool_features_helpers.mli @@ -0,0 +1,15 @@ +(* + * Copyright (C) 2024 Cloud Software Group + * + * 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. + *) + +val update_pool_features : __context:Context.t -> unit diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 768f33aba7b..f366b7414db 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -1120,7 +1120,7 @@ let destroy ~__context ~self = Db.Host.destroy ~__context ~self ; Create_misc.create_pool_cpuinfo ~__context ; List.iter (fun vm -> Db.VM.destroy ~__context ~self:vm) my_control_domains ; - Pool_features.update_pool_features ~__context + Pool_features_helpers.update_pool_features ~__context let declare_dead ~__context ~host = precheck_destroy_declare_dead ~__context ~self:host "declare_dead" ; @@ -2032,7 +2032,7 @@ let copy_license_to_db ~__context ~host:_ ~features ~additional = let set_license_params ~__context ~self ~value = Db.Host.set_license_params ~__context ~self ~value ; - Pool_features.update_pool_features ~__context + Pool_features_helpers.update_pool_features ~__context let apply_edition_internal ~__context ~host ~edition ~additional = (* Get localhost's current license state. *) diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index f4736a1a61f..cbd4fc03453 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -1991,7 +1991,7 @@ let eject ~__context ~host = Create_misc.create_pool_cpuinfo ~__context ; (* Update pool features, in case this host had a different license to the * rest of the pool. *) - Pool_features.update_pool_features ~__context + Pool_features_helpers.update_pool_features ~__context | true, true -> raise Cannot_eject_master From 22259d0f1d6a82dc7fa0c93cb2fefb7851c47661 Mon Sep 17 00:00:00 2001 From: Lunfan Zhang Date: Mon, 29 Apr 2024 06:58:50 -0400 Subject: [PATCH 08/44] CP-47656 Anti-affinity feature generate alert The generation of breach alerts during operations on VMs or groups, triggered when all running VMs within a group are breached (i.e., placed on the same host). The following may generate or dismiss alerts: Starting and resuming a VM. Stopping and suspending a VM. Pausing and unpausing a VM. Migrating a VM. Moving a VM from one group to another. Destroying a VM group. Changing the license from Premium to Standard dismisses all breach alerts, while changing from Standard to Premium generates them. In other scenarios, such as when a VM changes state from paused to shutdown, rebooting the VM will not trigger or dismiss alerts. Signed-off-by: Lunfan Zhang --- ocaml/xapi-consts/api_messages.ml | 3 + ocaml/xapi/message_forwarding.ml | 7 +- ocaml/xapi/pool_features.ml | 2 - ocaml/xapi/pool_features_helpers.ml | 6 +- ocaml/xapi/pool_features_helpers.mli | 2 +- ocaml/xapi/xapi_vm_group_helpers.ml | 205 +++++++++++++++++++++++++++ ocaml/xapi/xapi_vm_group_helpers.mli | 44 ++++++ ocaml/xapi/xapi_vm_lifecycle.ml | 4 + ocaml/xapi/xapi_vm_migrate.ml | 4 +- 9 files changed, 269 insertions(+), 8 deletions(-) mode change 100755 => 100644 ocaml/xapi/pool_features_helpers.ml create mode 100644 ocaml/xapi/xapi_vm_group_helpers.ml create mode 100644 ocaml/xapi/xapi_vm_group_helpers.mli diff --git a/ocaml/xapi-consts/api_messages.ml b/ocaml/xapi-consts/api_messages.ml index bb63facfe2a..5d9160152c2 100644 --- a/ocaml/xapi-consts/api_messages.ml +++ b/ocaml/xapi-consts/api_messages.ml @@ -365,3 +365,6 @@ let periodic_update_sync_failed = addMessage "PERIODIC_UPDATE_SYNC_FAILED" 3L let xapi_startup_blocked_as_version_higher_than_coordinator = addMessage "XAPI_STARTUP_BLOCKED_AS_VERSION_HIGHER_THAN_COORDINATOR" 2L + +let all_running_vms_in_anti_affinity_grp_on_single_host = + addMessage "ALL_RUNNING_VMS_IN_ANTI_AFFINITY_GRP_ON_SINGLE_HOST" 3L diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 06fbe9ceb13..bee46eb6925 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -3011,7 +3011,10 @@ functor info "VM.set_groups : self = '%s'; value = [ %s ]" (vm_uuid ~__context self) (String.concat "; " (List.map (vm_group_uuid ~__context) value)) ; - Local.VM.set_groups ~__context ~self ~value + let original_groups = Db.VM.get_groups ~__context ~self in + Local.VM.set_groups ~__context ~self ~value ; + Xapi_vm_group_helpers.update_vm_anti_affinity_alert ~__context + ~groups:(original_groups @ value) let import_convert ~__context ~_type ~username ~password ~sr ~remote_config = @@ -6564,6 +6567,8 @@ functor let destroy ~__context ~self = info "VM_group.destroy: self = '%s'" (vm_group_uuid ~__context self) ; + Xapi_vm_group_helpers.remove_vm_anti_affinity_alert ~__context + ~groups:[self] ; Local.VM_group.destroy ~__context ~self end diff --git a/ocaml/xapi/pool_features.ml b/ocaml/xapi/pool_features.ml index 862f11e3004..8821224872a 100644 --- a/ocaml/xapi/pool_features.ml +++ b/ocaml/xapi/pool_features.ml @@ -13,8 +13,6 @@ open Features -module D = Debug.Make (struct let name = "pool_features" end) - (* Terminology: - (Feature) flags: The keys in pool.restriction and host.license_params. Strings like "restrict_dmc". diff --git a/ocaml/xapi/pool_features_helpers.ml b/ocaml/xapi/pool_features_helpers.ml old mode 100755 new mode 100644 index a732320271a..dda8619013c --- a/ocaml/xapi/pool_features_helpers.ml +++ b/ocaml/xapi/pool_features_helpers.ml @@ -1,5 +1,5 @@ (* - * Copyright (C) 2024 Cloud Software Group + * Copyright (c) 2024 Cloud Software Group * * 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 @@ -102,7 +102,7 @@ let update_pool_features ~__context = info "Old pool features enabled: %s" (to_compact_string old_core_features) ; info "New pool features enabled: %s" (to_compact_string new_core_features) ; Db.Pool.set_restrictions ~__context ~self:pool ~value:new_restrictions ; - Xapi_vm_group_helpers.update_vm_placement_alert_when_restriction_change - ~__context ~old_restrictions ~new_restrictions ; + Xapi_vm_group_helpers.maybe_update_alerts_on_feature_change ~__context + ~old_restrictions ~new_restrictions ; Xapi_pool_helpers.apply_guest_agent_config ~__context ) diff --git a/ocaml/xapi/pool_features_helpers.mli b/ocaml/xapi/pool_features_helpers.mli index 1b7c52ff1fe..d5d610a3544 100755 --- a/ocaml/xapi/pool_features_helpers.mli +++ b/ocaml/xapi/pool_features_helpers.mli @@ -1,5 +1,5 @@ (* - * Copyright (C) 2024 Cloud Software Group + * Copyright (c) 2024 Cloud Software Group * * 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 diff --git a/ocaml/xapi/xapi_vm_group_helpers.ml b/ocaml/xapi/xapi_vm_group_helpers.ml new file mode 100644 index 00000000000..82d9ebc3508 --- /dev/null +++ b/ocaml/xapi/xapi_vm_group_helpers.ml @@ -0,0 +1,205 @@ +(* + * Copyright (c) 2024 Cloud Software Group + * + * 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. + *) + +module D = Debug.Make (struct let name = "xapi_vm_group_helpers" end) + +open D + +(** Check the breach state of a group. + When there are no VMs or only one VM in the group, it is not considered a breach. + when there are two or more VMs and all of them are on the same host, it is considered a breach, and the specific host is returned. +*) +let check_breach_on_vm_anti_affinity_rules ~__context ~group = + Db.VM_group.get_VMs ~__context ~self:group + |> List.filter_map (fun vm -> + let vm_rec = Db.VM.get_record ~__context ~self:vm in + match (vm_rec.API.vM_power_state, vm_rec.API.vM_resident_on) with + | `Running, h when h <> Ref.null -> + Some h + | _ -> + None + ) + |> function + | [] | [_] -> + None + | h :: remaining -> + if List.exists (fun h' -> h' <> h) remaining then + None + else + Some h + +let report_anti_affinity_alert ~__context ~group ~host = + let group_uuid = Db.VM_group.get_uuid ~__context ~self:group in + let host_uuid = Db.Host.get_uuid ~__context ~self:host in + let body = + String.concat "" + [ + "Breach on VM anti-affinity rules" + ; group_uuid + ; "" + ; host_uuid + ; "" + ] + in + let obj_uuid = + Db.Pool.get_uuid ~__context ~self:(Helpers.get_pool ~__context) + in + Xapi_alert.add + ~msg:Api_messages.all_running_vms_in_anti_affinity_grp_on_single_host + ~cls:`Pool ~obj_uuid ~body + +let get_anti_affinity_alerts ~__context = + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.Message.get_all_records ~rpc ~session_id + ) + |> List.filter (fun (_, record) -> + record.API.message_name + = fst Api_messages.all_running_vms_in_anti_affinity_grp_on_single_host + ) + +let alert_matched ~__context ~label_name ~id alert = + let alert_rec = snd alert in + match Xml.parse_string alert_rec.API.message_body with + | Xml.Element ("body", _, children) -> ( + let filtered = + List.filter_map + (function + | Xml.Element (name, _, [Xml.PCData v]) when name = label_name -> + Some v + | _ -> + None + ) + children + in + match filtered with [uuid] when uuid = id -> true | _ -> false + ) + | _ -> + let msg = "Invalid message body of VM group alert" in + error "%s" msg ; + raise Api_errors.(Server_error (internal_error, [msg])) + | exception e -> + let msg = Printf.sprintf "%s" (ExnHelper.string_of_exn e) in + error "%s" msg ; + raise Api_errors.(Server_error (internal_error, [msg])) + +let filter_alerts_with_group ~__context ~group ~alerts = + let group_uuid = Db.VM_group.get_uuid ~__context ~self:group in + List.filter + (alert_matched ~__context ~label_name:"VM_group" ~id:group_uuid) + alerts + +let filter_alerts_with_host ~__context ~host ~alerts = + let host_uuid = Db.Host.get_uuid ~__context ~self:host in + List.filter (alert_matched ~__context ~label_name:"host" ~id:host_uuid) alerts + +(** If it is a breach and no alerts exist, generate one, + If it is not a breach and alerts exist, dismiss the existing alert *) +let update_vm_anti_affinity_alert_for_group ~__context ~group ~alerts = + let breach_on_host = + check_breach_on_vm_anti_affinity_rules ~__context ~group + in + debug "[Anti-affinity] existing alerts of group (UUID: %s) is: %d" + (Db.VM_group.get_uuid ~__context ~self:group) + (List.length alerts) ; + match (alerts, breach_on_host) with + | [], Some host -> + report_anti_affinity_alert ~__context ~group ~host + | alerts, None -> + List.iter + (fun (ref, _) -> + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.Message.destroy ~rpc ~session_id ~self:ref + ) + ) + alerts + | alerts, Some host when filter_alerts_with_host ~__context ~host ~alerts = [] + -> + List.iter + (fun (ref, _) -> + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.Message.destroy ~rpc ~session_id ~self:ref + ) + ) + alerts ; + report_anti_affinity_alert ~__context ~group ~host + | _, _ -> + () + +let maybe_update_vm_anti_affinity_alert_for_vm ~__context ~vm = + try + Db.VM.get_groups ~__context ~self:vm + |> List.filter (fun g -> + Db.VM_group.get_placement ~__context ~self:g = `anti_affinity + ) + |> function + | [] -> + () + | group :: _ -> + let alerts = get_anti_affinity_alerts ~__context in + let alerts_of_group = + filter_alerts_with_group ~__context ~group ~alerts + in + update_vm_anti_affinity_alert_for_group ~__context ~group + ~alerts:alerts_of_group + with e -> error "%s" (Printexc.to_string e) + +let remove_vm_anti_affinity_alert_for_group ~__context ~group ~alerts = + debug "[Anti-affinity] remove alert for group:%s" + (Db.VM_group.get_uuid ~__context ~self:group) ; + List.iter + (fun (ref, _) -> + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.Message.destroy ~rpc ~session_id ~self:ref + ) + ) + alerts + +let update_alert ~__context ~groups ~action = + try + let alerts = get_anti_affinity_alerts ~__context in + groups + |> List.filter (fun g -> + Db.VM_group.get_placement ~__context ~self:g = `anti_affinity + ) + |> List.iter (fun group -> + let alerts_of_group = + filter_alerts_with_group ~__context ~group ~alerts + in + action ~__context ~group ~alerts:alerts_of_group + ) + with e -> error "%s" (Printexc.to_string e) + +let update_vm_anti_affinity_alert ~__context ~groups = + update_alert ~__context ~groups + ~action:update_vm_anti_affinity_alert_for_group + +let remove_vm_anti_affinity_alert ~__context ~groups = + update_alert ~__context ~groups + ~action:remove_vm_anti_affinity_alert_for_group + +let maybe_update_alerts_on_feature_change ~__context ~old_restrictions + ~new_restrictions = + try + let is_enabled restrictions = + List.mem Features.VM_anti_affinity (Features.of_assoc_list restrictions) + in + let groups = Db.VM_group.get_all ~__context in + match (is_enabled old_restrictions, is_enabled new_restrictions) with + | false, true -> + update_vm_anti_affinity_alert ~__context ~groups + | true, false -> + remove_vm_anti_affinity_alert ~__context ~groups + | _, _ -> + () + with e -> error "%s" (Printexc.to_string e) diff --git a/ocaml/xapi/xapi_vm_group_helpers.mli b/ocaml/xapi/xapi_vm_group_helpers.mli new file mode 100644 index 00000000000..310ca5568e9 --- /dev/null +++ b/ocaml/xapi/xapi_vm_group_helpers.mli @@ -0,0 +1,44 @@ +(* + * Copyright (c) 2024 Cloud Software Group + * + * 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. + *) + +val maybe_update_vm_anti_affinity_alert_for_vm : + __context:Context.t -> vm:[`VM] API.Ref.t -> unit +(** updates VM anti-affinity alert with a given VM.*) + +val remove_vm_anti_affinity_alert : + __context:Context.t -> groups:[`VM_group] API.Ref.t list -> unit +(** removes VM anti-affinity alert with given groups.*) + +val update_vm_anti_affinity_alert : + __context:Context.t -> groups:[`VM_group] API.Ref.t list -> unit +(** updates VM anti-affinity alert with given groups.*) + +val maybe_update_alerts_on_feature_change : + __context:Context.t + -> old_restrictions:(string * string) list + -> new_restrictions:(string * string) list + -> unit +(** Updates the VM anti-affinity alert only when Features.VM_anti_affinity changes. + + @param __context The context information. + @param old_restrictions The old feature restrictions represented as an association list. + Each entry in the list contains a feature identifier and its corresponding restriction status. + @param new_restrictions The new feature restrictions represented as an association list. + Each entry in the list contains a feature identifier and its corresponding restriction status. + Example: + [ + ("restrict_vlan", "true"); + ("restrict_vm_anti_affinity", "false") + ] +*) diff --git a/ocaml/xapi/xapi_vm_lifecycle.ml b/ocaml/xapi/xapi_vm_lifecycle.ml index ccee66500cd..2f6130641df 100644 --- a/ocaml/xapi/xapi_vm_lifecycle.ml +++ b/ocaml/xapi/xapi_vm_lifecycle.ml @@ -850,6 +850,7 @@ let remove_pending_guidance ~__context ~self ~value = 2. Called on update VM when the power state changes *) let force_state_reset_keep_current_operations ~__context ~self ~value:state = (* First update the power_state. Some operations below indirectly rely on this. *) + let old_state = Db.VM.get_power_state ~__context ~self in Db.VM.set_power_state ~__context ~self ~value:state ; if state = `Suspended then remove_pending_guidance ~__context ~self ~value:`restart_device_model ; @@ -941,6 +942,9 @@ let force_state_reset_keep_current_operations ~__context ~self ~value:state = (Db.PCI.get_all ~__context) ) ; update_allowed_operations ~__context ~self ; + if old_state <> state && (old_state = `Running || state = `Running) then + Xapi_vm_group_helpers.maybe_update_vm_anti_affinity_alert_for_vm ~__context + ~vm:self ; if state = `Halted then (* archive the rrd for this vm *) let vm_uuid = Db.VM.get_uuid ~__context ~self in let master_address = Pool_role.get_master_address_opt () in diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index 13d112fd3ce..43993c4fcf9 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -490,7 +490,9 @@ let pool_migrate_complete ~__context ~vm ~host:_ = Xapi_xenops.add_caches id ; Xapi_xenops.refresh_vm ~__context ~self:vm ; Monitor_dbcalls_cache.clear_cache_for_vm ~vm_uuid:id - ) + ) ; + Xapi_vm_group_helpers.maybe_update_vm_anti_affinity_alert_for_vm ~__context + ~vm type mirror_record = { mr_mirrored: bool From ab19a9c882cf94260557b4479510e4f2f818bef1 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Tue, 21 May 2024 16:39:43 +0800 Subject: [PATCH 09/44] CP-48570: Add a field 'recommendations' in pool The recommendations are read from files '/etc/xapi.pool-recommendations.d/*' and exposed to clients. They are read-only and only for clients, hence they don't impact the behavior of Xapi directly but only indirectly as they inform a client's behavior. Signed-off-by: Bengang Yuan --- ocaml/idl/datamodel_pool.ml | 5 +++++ ocaml/idl/schematest.ml | 2 +- ocaml/tests/common/test_common.ml | 5 +++-- ocaml/xapi-cli-server/records.ml | 6 ++++++ ocaml/xapi/dbsync_master.ml | 2 +- 5 files changed, 16 insertions(+), 4 deletions(-) diff --git a/ocaml/idl/datamodel_pool.ml b/ocaml/idl/datamodel_pool.ml index f556cf56407..249923c73e2 100644 --- a/ocaml/idl/datamodel_pool.ml +++ b/ocaml/idl/datamodel_pool.ml @@ -1490,6 +1490,11 @@ let t = ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:Bool ~default_value:(Some (VBool false)) "update_sync_enabled" "Whether periodic update synchronization is enabled or not" + ; field ~qualifier:DynamicRO ~lifecycle:[] + ~ty:(Map (String, String)) + ~default_value:(Some (VMap [])) "recommendations" + "The recommended pool properties for clients to respect for \ + optimal performance. e.g. max-vm-group=5" ] ) () diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index 9d374a66e2c..2d839624ff3 100644 --- a/ocaml/idl/schematest.ml +++ b/ocaml/idl/schematest.ml @@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex (* BEWARE: if this changes, check that schema has been bumped accordingly in ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *) -let last_known_schema_hash = "81ba6b9699b3f6c2969dd5510cbbe4aa" +let last_known_schema_hash = "024b6ce32246d7549898310675631d51" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/tests/common/test_common.ml b/ocaml/tests/common/test_common.ml index cb7b24af99e..66ebe152627 100644 --- a/ocaml/tests/common/test_common.ml +++ b/ocaml/tests/common/test_common.ml @@ -298,7 +298,8 @@ let make_pool ~__context ~master ?(name_label = "") ?(name_description = "") ?(telemetry_uuid = Ref.null) ?(telemetry_frequency = `weekly) ?(telemetry_next_collection = API.Date.never) ?(last_update_sync = API.Date.epoch) ?(update_sync_frequency = `daily) - ?(update_sync_day = 0L) ?(update_sync_enabled = false) () = + ?(update_sync_day = 0L) ?(update_sync_enabled = false) + ?(recommendations = []) () = let pool_ref = Ref.make () in Db.Pool.create ~__context ~ref:pool_ref ~uuid:(make_uuid ()) ~name_label ~name_description ~master ~default_SR ~suspend_image_SR ~crash_dump_SR @@ -316,7 +317,7 @@ let make_pool ~__context ~master ?(name_label = "") ?(name_description = "") ~migration_compression ~coordinator_bias ~telemetry_uuid ~telemetry_frequency ~telemetry_next_collection ~last_update_sync ~local_auth_max_threads:8L ~ext_auth_max_threads:8L ~update_sync_frequency - ~update_sync_day ~update_sync_enabled ; + ~update_sync_day ~update_sync_enabled ~recommendations ; pool_ref let default_sm_features = diff --git a/ocaml/xapi-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index 2a78e105e5b..8b74ae360e9 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -1493,6 +1493,12 @@ let pool_record rpc session_id pool = ; make_field ~name:"update-sync-enabled" ~get:(fun () -> (x ()).API.pool_update_sync_enabled |> string_of_bool) () + ; make_field ~name:"recommendations" + ~get:(fun () -> + Record_util.s2sm_to_string "; " (x ()).API.pool_recommendations + ) + ~get_map:(fun () -> (x ()).API.pool_recommendations) + () ] } diff --git a/ocaml/xapi/dbsync_master.ml b/ocaml/xapi/dbsync_master.ml index 5cdc4b9106e..95626a9c98c 100644 --- a/ocaml/xapi/dbsync_master.ml +++ b/ocaml/xapi/dbsync_master.ml @@ -53,7 +53,7 @@ let create_pool_record ~__context = ~last_update_sync:Xapi_stdext_date.Date.epoch ~update_sync_frequency:`weekly ~update_sync_day:0L ~update_sync_enabled:false ~local_auth_max_threads:8L - ~ext_auth_max_threads:1L + ~ext_auth_max_threads:1L ~recommendations:[] let set_master_ip ~__context = let ip = From 1f9d39e4e66d68f7ff652e7fa14d0ca86d3b8d5d Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Tue, 21 May 2024 16:40:36 +0800 Subject: [PATCH 10/44] CP-48570: Load recommendations from config file when Xapi starts The recommendations are read from '/etc/xapi.pool-recommendations.d/*.conf'. When Xapi starts, it will read each file and update the recommendations into the database. If we need to add recommendations to other type objects, e.g. host, VM, etc in the future, just add a similar 'xapi.*-recommendations.d' directory and define the path in xapi_globs. Signed-off-by: Bengang Yuan --- ocaml/xapi/dbsync_master.ml | 16 ++++++++++- ocaml/xapi/recommendations.ml | 50 ++++++++++++++++++++++++++++++++++ ocaml/xapi/recommendations.mli | 17 ++++++++++++ ocaml/xapi/xapi_globs.ml | 6 ++++ 4 files changed, 88 insertions(+), 1 deletion(-) create mode 100644 ocaml/xapi/recommendations.ml create mode 100644 ocaml/xapi/recommendations.mli diff --git a/ocaml/xapi/dbsync_master.ml b/ocaml/xapi/dbsync_master.ml index 95626a9c98c..fc6584a3f67 100644 --- a/ocaml/xapi/dbsync_master.ml +++ b/ocaml/xapi/dbsync_master.ml @@ -19,6 +19,7 @@ module D = Debug.Make (struct let name = "dbsync" end) open D open Client +open Recommendations (* Synchronising code which is specific to the master *) @@ -336,6 +337,18 @@ let setup_telemetry ~__context = ) () +let update_pool_recommendations_noexn ~__context = + Helpers.log_exn_continue "update pool recommendations" + (fun () -> + let pool = Helpers.get_pool ~__context in + let recommendations = + Recommendations.load ~path:!Xapi_globs.pool_recommendations_dir + |> StringMap.bindings + in + Db.Pool.set_recommendations ~__context ~self:pool ~value:recommendations + ) + () + (* Update the database to reflect current state. Called for both start of day and after an agent restart. *) let update_env __context = @@ -360,4 +373,5 @@ let update_env __context = Storage_access.on_xapi_start ~__context ; if !Xapi_globs.create_tools_sr then create_tools_sr_noexn __context ; - ensure_vm_metrics_records_exist_noexn __context + ensure_vm_metrics_records_exist_noexn __context ; + update_pool_recommendations_noexn ~__context diff --git a/ocaml/xapi/recommendations.ml b/ocaml/xapi/recommendations.ml new file mode 100644 index 00000000000..be35ba1316a --- /dev/null +++ b/ocaml/xapi/recommendations.ml @@ -0,0 +1,50 @@ +(* + * Copyright (c) Cloud Software Group, 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. + *) + +module Unixext = Xapi_stdext_unix.Unixext +module Config_file = Xcp_service.Config_file + +module D = Debug.Make (struct let name = "recommendations" end) + +open D +module StringMap = Map.Make (String) + +let process_line map data = + match Config_file.parse_line data with + | Some (k, v) -> + debug "Parsing data, key: %s, value: %s" k v ; + StringMap.add k v map + | None -> + map + +let parse map filename = + debug "Parsing recommendations file: %s" filename ; + Unixext.file_lines_fold process_line map filename + +let load ~path = + (try Sys.readdir path with _ -> [||]) + |> Array.to_list + |> List.filter (fun f -> Filename.check_suffix f ".conf") + |> List.stable_sort compare + |> List.map (Filename.concat path) + |> List.filter (fun f -> + match Unix.((stat f).st_kind) with + | Unix.S_REG -> + true + | _ -> + false + | exception _ -> + false + ) + |> List.fold_left parse StringMap.empty diff --git a/ocaml/xapi/recommendations.mli b/ocaml/xapi/recommendations.mli new file mode 100644 index 00000000000..a97a4a39c6d --- /dev/null +++ b/ocaml/xapi/recommendations.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) Cloud Software Group, 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. + *) + +module StringMap : Map.S with type key = string + +val load : path:string -> string StringMap.t diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index 37e9f561537..ca913c57254 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -1023,6 +1023,8 @@ let python3_path = ref "/usr/bin/python3" let observer_experimental_components = ref (StringSet.singleton Constants.observer_component_smapi) +let pool_recommendations_dir = ref "/etc/xapi.pool-recommendations.d" + let xapi_globs_spec = [ ( "master_connection_reset_timeout" @@ -1803,6 +1805,10 @@ module Resources = struct , trace_log_dir , "Directory for storing traces exported to logs" ) + ; ( "pool-recommendations-dir" + , pool_recommendations_dir + , "Directory containing files with recommendations in key=value format" + ) ] let xcp_resources = From 606423e3dfa5e94043f913f4f466cfb5985cfaf3 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Tue, 30 Apr 2024 02:18:27 -0400 Subject: [PATCH 11/44] CP-48011: Xapi Support anti-affinity feature flag Check feature flag in these places: 1. VM start. 2. Host evacuation. When this PR is raised, the host evacuation PR is still in review. So this PR doesn't include the checking for host evacuation. It will be included in another new PR. 3. Create VM group. 4. VM.set_groups. Adding VMs to a group and removing VMs from a group are all forbidden. If customers need to remove VMs from a group, just destroy the group. 5. Send VM anti-affinity alerts. Also, based on our discussion, the name of feature is changed from `VM_anti_affinity` to `VM_group`. Signed-off-by: Bengang Yuan --- ocaml/xapi-types/features.ml | 6 +-- ocaml/xapi-types/features.mli | 2 +- ocaml/xapi/xapi_vm.ml | 1 + ocaml/xapi/xapi_vm_group.ml | 1 + ocaml/xapi/xapi_vm_group_helpers.ml | 56 ++++++++++++++++------------ ocaml/xapi/xapi_vm_group_helpers.mli | 4 +- ocaml/xapi/xapi_vm_helpers.ml | 30 +++++++++------ 7 files changed, 57 insertions(+), 43 deletions(-) diff --git a/ocaml/xapi-types/features.ml b/ocaml/xapi-types/features.ml index d55d7d01c37..97fc9b7f7f5 100644 --- a/ocaml/xapi-types/features.ml +++ b/ocaml/xapi-types/features.ml @@ -64,7 +64,7 @@ type feature = | Updates | Internal_repo_access | VTPM - | VM_anti_affinity + | VM_group [@@deriving rpc] type orientation = Positive | Negative @@ -133,9 +133,7 @@ let keys_of_features = , ("restrict_internal_repo_access", Negative, "Internal_repo_access") ) ; (VTPM, ("restrict_vtpm", Negative, "VTPM")) - ; ( VM_anti_affinity - , ("restrict_vm_anti_affinity", Negative, "VM_anti_affinity") - ) + ; (VM_group, ("restrict_vm_group", Negative, "VM_group")) ] (* A list of features that must be considered "enabled" by `of_assoc_list` diff --git a/ocaml/xapi-types/features.mli b/ocaml/xapi-types/features.mli index 0696b3ddb5e..bae1496dd78 100644 --- a/ocaml/xapi-types/features.mli +++ b/ocaml/xapi-types/features.mli @@ -72,7 +72,7 @@ type feature = | Internal_repo_access (** Enable restriction on repository access to pool members only *) | VTPM (** Support VTPM device required by Win11 guests *) - | VM_anti_affinity (** Enable use of VM anti-affinity placement *) + | VM_group (** Enable use of VM group *) val feature_of_rpc : Rpc.t -> feature (** Convert RPC into {!feature}s *) diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index e83bee43d15..93fbf05c8b0 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1442,6 +1442,7 @@ let set_appliance ~__context ~self ~value = update_allowed_operations ~__context ~self let set_groups ~__context ~self ~value = + Pool_features.assert_enabled ~__context ~f:Features.VM_group ; if List.length value > 1 then raise Api_errors.(Server_error (Api_errors.too_many_groups, [])) ; Db.VM.set_groups ~__context ~self ~value diff --git a/ocaml/xapi/xapi_vm_group.ml b/ocaml/xapi/xapi_vm_group.ml index 0d77e9d3f51..f04d73e213a 100644 --- a/ocaml/xapi/xapi_vm_group.ml +++ b/ocaml/xapi/xapi_vm_group.ml @@ -15,6 +15,7 @@ module D = Debug.Make (struct let name = "xapi_vm_group" end) let create ~__context ~name_label ~name_description ~placement = + Pool_features.assert_enabled ~__context ~f:Features.VM_group ; let uuid = Uuidx.make () in let ref = Ref.make () in Db.VM_group.create ~__context ~ref ~uuid:(Uuidx.to_string uuid) ~name_label diff --git a/ocaml/xapi/xapi_vm_group_helpers.ml b/ocaml/xapi/xapi_vm_group_helpers.ml index 82d9ebc3508..0a05f41dd96 100644 --- a/ocaml/xapi/xapi_vm_group_helpers.ml +++ b/ocaml/xapi/xapi_vm_group_helpers.ml @@ -16,9 +16,11 @@ module D = Debug.Make (struct let name = "xapi_vm_group_helpers" end) open D -(** Check the breach state of a group. - When there are no VMs or only one VM in the group, it is not considered a breach. - when there are two or more VMs and all of them are on the same host, it is considered a breach, and the specific host is returned. +(* Check the breach state of a group. + When there are no VMs or only one VM in the group, it is not considered a + breach. + when there are two or more VMs and all of them are on the same host, it is + considered a breach, and the specific host is returned. *) let check_breach_on_vm_anti_affinity_rules ~__context ~group = Db.VM_group.get_VMs ~__context ~self:group @@ -103,8 +105,8 @@ let filter_alerts_with_host ~__context ~host ~alerts = let host_uuid = Db.Host.get_uuid ~__context ~self:host in List.filter (alert_matched ~__context ~label_name:"host" ~id:host_uuid) alerts -(** If it is a breach and no alerts exist, generate one, - If it is not a breach and alerts exist, dismiss the existing alert *) +(* If it is a breach and no alerts exist, generate one, + If it is not a breach and alerts exist, dismiss the existing alert *) let update_vm_anti_affinity_alert_for_group ~__context ~group ~alerts = let breach_on_host = check_breach_on_vm_anti_affinity_rules ~__context ~group @@ -137,22 +139,25 @@ let update_vm_anti_affinity_alert_for_group ~__context ~group ~alerts = () let maybe_update_vm_anti_affinity_alert_for_vm ~__context ~vm = - try - Db.VM.get_groups ~__context ~self:vm - |> List.filter (fun g -> - Db.VM_group.get_placement ~__context ~self:g = `anti_affinity - ) - |> function - | [] -> - () - | group :: _ -> - let alerts = get_anti_affinity_alerts ~__context in - let alerts_of_group = - filter_alerts_with_group ~__context ~group ~alerts - in - update_vm_anti_affinity_alert_for_group ~__context ~group - ~alerts:alerts_of_group - with e -> error "%s" (Printexc.to_string e) + if Pool_features.is_enabled ~__context Features.VM_group then + try + Db.VM.get_groups ~__context ~self:vm + |> List.filter (fun g -> + Db.VM_group.get_placement ~__context ~self:g = `anti_affinity + ) + |> function + | [] -> + () + | group :: _ -> + let alerts = get_anti_affinity_alerts ~__context in + let alerts_of_group = + filter_alerts_with_group ~__context ~group ~alerts + in + update_vm_anti_affinity_alert_for_group ~__context ~group + ~alerts:alerts_of_group + with e -> error "%s" (Printexc.to_string e) + else + debug "VM group feature is disabled, alert will not be updated" let remove_vm_anti_affinity_alert_for_group ~__context ~group ~alerts = debug "[Anti-affinity] remove alert for group:%s" @@ -181,8 +186,11 @@ let update_alert ~__context ~groups ~action = with e -> error "%s" (Printexc.to_string e) let update_vm_anti_affinity_alert ~__context ~groups = - update_alert ~__context ~groups - ~action:update_vm_anti_affinity_alert_for_group + if Pool_features.is_enabled ~__context Features.VM_group then + update_alert ~__context ~groups + ~action:update_vm_anti_affinity_alert_for_group + else + debug "VM group feature is disabled, alert will not be updated" let remove_vm_anti_affinity_alert ~__context ~groups = update_alert ~__context ~groups @@ -192,7 +200,7 @@ let maybe_update_alerts_on_feature_change ~__context ~old_restrictions ~new_restrictions = try let is_enabled restrictions = - List.mem Features.VM_anti_affinity (Features.of_assoc_list restrictions) + List.mem Features.VM_group (Features.of_assoc_list restrictions) in let groups = Db.VM_group.get_all ~__context in match (is_enabled old_restrictions, is_enabled new_restrictions) with diff --git a/ocaml/xapi/xapi_vm_group_helpers.mli b/ocaml/xapi/xapi_vm_group_helpers.mli index 310ca5568e9..c7ed83e39e1 100644 --- a/ocaml/xapi/xapi_vm_group_helpers.mli +++ b/ocaml/xapi/xapi_vm_group_helpers.mli @@ -29,7 +29,7 @@ val maybe_update_alerts_on_feature_change : -> old_restrictions:(string * string) list -> new_restrictions:(string * string) list -> unit -(** Updates the VM anti-affinity alert only when Features.VM_anti_affinity changes. +(** Updates the VM anti-affinity alert only when Features.VM_group changes. @param __context The context information. @param old_restrictions The old feature restrictions represented as an association list. @@ -39,6 +39,6 @@ val maybe_update_alerts_on_feature_change : Example: [ ("restrict_vlan", "true"); - ("restrict_vm_anti_affinity", "false") + ("restrict_vm_group", "false") ] *) diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index 2e07c7670cc..9d310d94eeb 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -913,18 +913,24 @@ let vm_can_run_on_host ~__context ~vm ~snapshot ~do_memory_check host = with _ -> false let vm_has_anti_affinity ~__context ~vm = - List.find_opt - (fun g -> Db.VM_group.get_placement ~__context ~self:g = `anti_affinity) - (Db.VM.get_groups ~__context ~self:vm) - |> Option.map (fun group -> - debug - "The VM (uuid %s) is associated with an anti-affinity group (uuid: \ - %s, name: %s)" - (Db.VM.get_uuid ~__context ~self:vm) - (Db.VM_group.get_uuid ~__context ~self:group) - (Db.VM_group.get_name_label ~__context ~self:group) ; - `AntiAffinity group - ) + if Pool_features.is_enabled ~__context Features.VM_group then + List.find_opt + (fun g -> Db.VM_group.get_placement ~__context ~self:g = `anti_affinity) + (Db.VM.get_groups ~__context ~self:vm) + |> Option.map (fun group -> + debug + "The VM (uuid %s) is associated with an anti-affinity group \ + (uuid: %s, name: %s)" + (Db.VM.get_uuid ~__context ~self:vm) + (Db.VM_group.get_uuid ~__context ~self:group) + (Db.VM_group.get_name_label ~__context ~self:group) ; + `AntiAffinity group + ) + else ( + debug + "VM group feature is disabled, ignore VM anti-affinity during VM start" ; + None + ) let vm_has_vgpu ~__context ~vm = match Db.VM.get_VGPUs ~__context ~self:vm with From 7fcef06a6858a7cdd6cfd2c925369b451c12db18 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Tue, 28 May 2024 09:46:57 +0100 Subject: [PATCH 12/44] CA-393421: Special VMs cannot be added to VM groups Control domains, templates, and snapshots cannot be added to VM groups. Signed-off-by: Bengang Yuan --- ocaml/idl/datamodel_vm.ml | 1 + ocaml/xapi/xapi_vm.ml | 14 ++++++++++++++ 2 files changed, 15 insertions(+) diff --git a/ocaml/idl/datamodel_vm.ml b/ocaml/idl/datamodel_vm.ml index 80622f8ea44..a6ddc015214 100644 --- a/ocaml/idl/datamodel_vm.ml +++ b/ocaml/idl/datamodel_vm.ml @@ -1521,6 +1521,7 @@ let set_groups = (Ref _vm, "self", "The VM") ; (Set (Ref _vm_group), "value", "The VM groups to set") ] + ~errs:[Api_errors.operation_not_allowed] ~allowed_roles:_R_VM_ADMIN () let call_plugin = diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 93fbf05c8b0..c08877c54c7 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1443,6 +1443,20 @@ let set_appliance ~__context ~self ~value = let set_groups ~__context ~self ~value = Pool_features.assert_enabled ~__context ~f:Features.VM_group ; + if + Db.VM.get_is_control_domain ~__context ~self + || Db.VM.get_is_a_template ~__context ~self + || Db.VM.get_is_a_snapshot ~__context ~self + then + raise + (Api_errors.Server_error + ( Api_errors.operation_not_allowed + , [ + "Control domains, templates, and snapshots cannot be added to VM \ + groups." + ] + ) + ) ; if List.length value > 1 then raise Api_errors.(Server_error (Api_errors.too_many_groups, [])) ; Db.VM.set_groups ~__context ~self ~value From 1efaf1f2f1b9848d9130e2bb312d2bd879a02c2a Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Thu, 16 May 2024 16:49:39 +0800 Subject: [PATCH 13/44] CP-48625: Code refactoring Add func host_to_vm_count_map to be used, rename RefMap to HostMap Signed-off-by: Gang Ji --- ocaml/xapi/xapi_vm_helpers.ml | 89 +++++++++++++++++++++++++++-------- 1 file changed, 70 insertions(+), 19 deletions(-) diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index 9d310d94eeb..99fdabc6d38 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -35,7 +35,7 @@ module SRSet = Set.Make (struct let compare = Stdlib.compare end) -module RefMap = Map.Make (struct +module HostMap = Map.Make (struct type t = [`host] Ref.t let compare = Ref.compare @@ -1003,6 +1003,46 @@ let rank_hosts_by_best_vgpu ~__context vgpu visible_hosts = hosts |> List.map (fun g -> List.map fst g) +let host_to_vm_count_map ~__context group = + let host_of_vm vm = + let vm_rec = Db.VM.get_record ~__context ~self:vm in + (* 1. When a VM starts migrating, it's 'scheduled_to_be_resident_on' will be set, + while its 'resident_on' is not cleared. In this case, + 'scheduled_to_be_resident_on' should be treated as its running host. + 2. For paused VM, its 'resident_on' has value, but it will not be considered + while computing the amount of VMs. *) + match + ( vm_rec.API.vM_scheduled_to_be_resident_on + , vm_rec.API.vM_resident_on + , vm_rec.API.vM_power_state + ) + with + | sh, _, _ when sh <> Ref.null -> + Some sh + | _, h, `Running when h <> Ref.null -> + Some h + | _ -> + None + in + Db.VM_group.get_VMs ~__context ~self:group + |> List.fold_left + (fun m vm -> + match host_of_vm vm with + | Some h -> + HostMap.update h + (fun c -> Option.(value ~default:0 c |> succ |> some)) + m + | None -> + m + ) + HostMap.empty + +let rank_hosts_by_vm_cnt_in_group ~__context group hosts = + let host_map = host_to_vm_count_map ~__context group in + Helpers.group_by ~ordering:`ascending + (fun h -> HostMap.find_opt h host_map |> Option.value ~default:0) + hosts + (* Group all hosts to 2 parts: 1. A list of affinity host (only one host). 2. A list of lists, each list contains hosts with the same number of @@ -1055,22 +1095,43 @@ let rank_hosts_by_placement ~__context ~vm ~group = (fun m vm -> match host_of_vm vm with | Some h -> - RefMap.update h + HostMap.update h (fun c -> Option.(value ~default:0 c |> succ |> some)) m | None -> m ) - RefMap.empty + HostMap.empty in host_without_affinity_host |> Helpers.group_by ~ordering:`ascending (fun h -> - RefMap.find_opt h host_map |> Option.value ~default:0 + HostMap.find_opt h host_map |> Option.value ~default:0 ) |> List.map (fun g -> List.map fst g) in affinity_host :: sorted_hosts |> List.filter (( <> ) []) +let rec select_host_from_ranked_lists ~vm ~host_selector ~ranked_host_lists = + match ranked_host_lists with + | [] -> + raise (Api_errors.Server_error (Api_errors.no_hosts_available, [])) + | hosts :: less_optimal_groups_of_hosts -> ( + debug + "Attempting to select host for VM (%s) in a group of equally optimal \ + hosts [ %s ]" + (Ref.string_of vm) + (String.concat ";" (List.map Ref.string_of hosts)) ; + try host_selector hosts + with _ -> + info + "Failed to select host for VM (%s) in any of [ %s ], continue to \ + select from less optimal hosts" + (Ref.string_of vm) + (String.concat ";" (List.map Ref.string_of hosts)) ; + select_host_from_ranked_lists ~vm ~host_selector + ~ranked_host_lists:less_optimal_groups_of_hosts + ) + (* Selects a single host from the set of all hosts on which the given [vm] can boot. Raises [Api_errors.no_hosts_available] if no such host exists. 1.Take anti-affinity, or VGPU, or Network SR-IOV as a group_key for group all hosts into host list list @@ -1115,22 +1176,12 @@ let choose_host_for_vm_no_wlb ~__context ~vm ~snapshot = ) ) in - let rec select_host_from = function - | [] -> - raise (Api_errors.Server_error (Api_errors.no_hosts_available, [])) - | hosts :: less_optimal_groups_of_hosts -> ( - debug - "Attempting to start VM (%s) on one of equally optimal hosts [ %s ]" - (Ref.string_of vm) - (String.concat ";" (List.map Ref.string_of hosts)) ; - try Xapi_vm_placement.select_host __context vm validate_host hosts - with _ -> - info "Failed to start VM (%s) on any of [ %s ]" (Ref.string_of vm) - (String.concat ";" (List.map Ref.string_of hosts)) ; - select_host_from less_optimal_groups_of_hosts - ) + let host_selector = + Xapi_vm_placement.select_host __context vm validate_host in - try select_host_from host_lists + try + select_host_from_ranked_lists ~vm ~host_selector + ~ranked_host_lists:host_lists with | Api_errors.Server_error (x, []) when x = Api_errors.no_hosts_available -> debug From d1316f13c8e2d0fa832538e7ec0ab5422c1d86d4 Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Thu, 16 May 2024 16:59:42 +0800 Subject: [PATCH 14/44] CP-48625: Code refactoring fixup review comments Signed-off-by: Gang Ji --- ocaml/xapi/xapi_vm_helpers.ml | 78 +++++++++++------------------------ 1 file changed, 24 insertions(+), 54 deletions(-) diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index 99fdabc6d38..cc82f304e07 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -1043,6 +1043,13 @@ let rank_hosts_by_vm_cnt_in_group ~__context group hosts = (fun h -> HostMap.find_opt h host_map |> Option.value ~default:0) hosts +let get_affinity_host ~__context ~vm = + match Db.VM.get_affinity ~__context ~self:vm with + | ref when Db.is_valid_ref __context ref -> + Some ref + | _ -> + None + (* Group all hosts to 2 parts: 1. A list of affinity host (only one host). 2. A list of lists, each list contains hosts with the same number of @@ -1057,77 +1064,40 @@ let rank_hosts_by_vm_cnt_in_group ~__context group hosts = ] *) let rank_hosts_by_placement ~__context ~vm ~group = - let affinity_host = - match Db.VM.get_affinity ~__context ~self:vm with - | ref when Db.is_valid_ref __context ref -> - [ref] - | _ -> - [] + let hosts = Db.Host.get_all ~__context in + let affinity_host = get_affinity_host ~__context ~vm in + let hosts_without_affinity = + Option.fold ~none:hosts + ~some:(fun host -> List.filter (( <> ) host) hosts) + affinity_host in let sorted_hosts = - let host_without_affinity_host = - Db.Host.get_all ~__context - |> List.filter (fun host -> not (List.mem host affinity_host)) - in - let host_of_vm vm = - let vm_rec = Db.VM.get_record ~__context ~self:vm in - (* 1. When a VM starts migrating, it's 'scheduled_to_be_resident_on' will be set, - while its 'resident_on' is not cleared. In this case, - 'scheduled_to_be_resident_on' should be treated as its running host. - 2. For paused VM, its 'resident_on' has value, but it will not be considered - while computing the amount of VMs. *) - match - ( vm_rec.API.vM_scheduled_to_be_resident_on - , vm_rec.API.vM_resident_on - , vm_rec.API.vM_power_state - ) - with - | sh, _, _ when sh <> Ref.null -> - Some sh - | _, h, `Running when h <> Ref.null -> - Some h - | _ -> - None - in - let host_map = - Db.VM_group.get_VMs ~__context ~self:group - |> List.fold_left - (fun m vm -> - match host_of_vm vm with - | Some h -> - HostMap.update h - (fun c -> Option.(value ~default:0 c |> succ |> some)) - m - | None -> - m - ) - HostMap.empty - in - host_without_affinity_host - |> Helpers.group_by ~ordering:`ascending (fun h -> - HostMap.find_opt h host_map |> Option.value ~default:0 - ) - |> List.map (fun g -> List.map fst g) + hosts_without_affinity + |> rank_hosts_by_vm_cnt_in_group ~__context group + |> List.(map (map fst)) in - affinity_host :: sorted_hosts |> List.filter (( <> ) []) + match affinity_host with + | Some host -> + [host] :: sorted_hosts + | None -> + sorted_hosts let rec select_host_from_ranked_lists ~vm ~host_selector ~ranked_host_lists = match ranked_host_lists with | [] -> raise (Api_errors.Server_error (Api_errors.no_hosts_available, [])) | hosts :: less_optimal_groups_of_hosts -> ( + let hosts_str = String.concat ";" (List.map Ref.string_of hosts) in debug "Attempting to select host for VM (%s) in a group of equally optimal \ hosts [ %s ]" - (Ref.string_of vm) - (String.concat ";" (List.map Ref.string_of hosts)) ; + (Ref.string_of vm) hosts_str ; try host_selector hosts with _ -> info "Failed to select host for VM (%s) in any of [ %s ], continue to \ select from less optimal hosts" - (Ref.string_of vm) - (String.concat ";" (List.map Ref.string_of hosts)) ; + (Ref.string_of vm) hosts_str ; select_host_from_ranked_lists ~vm ~host_selector ~ranked_host_lists:less_optimal_groups_of_hosts ) From eaf79451ff027cd7679435c503287eaae0011062 Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Thu, 23 May 2024 15:56:05 +0800 Subject: [PATCH 15/44] opam: add psq to xapi dependencies Signed-off-by: Gang Ji --- ocaml/xapi/dune | 1 + xapi.opam | 1 + xapi.opam.template | 1 + 3 files changed, 3 insertions(+) diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 6575b66aea5..7492df39e68 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -84,6 +84,7 @@ pam pciutil pci + psq ptime rpclib.core rpclib.json diff --git a/xapi.opam b/xapi.opam index e414d694b2c..387ba542fe6 100644 --- a/xapi.opam +++ b/xapi.opam @@ -38,6 +38,7 @@ depends: [ "ppx_deriving_rpc" "ppx_sexp_conv" "ppx_deriving" + "psq" "rpclib" "rrdd-plugin" "rresult" diff --git a/xapi.opam.template b/xapi.opam.template index dc48554787e..49f3902f66a 100644 --- a/xapi.opam.template +++ b/xapi.opam.template @@ -36,6 +36,7 @@ depends: [ "ppx_deriving_rpc" "ppx_sexp_conv" "ppx_deriving" + "psq" "rpclib" "rrdd-plugin" "rresult" From 25fa2eb46e5e5138c581339ec156f65d40f336c3 Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Thu, 16 May 2024 16:37:06 +0800 Subject: [PATCH 16/44] CP-49665: Anti-affinity support for host evacuation Host evacuation plan with anti-affinity support will be carried out in 3 phases: 1. Try to get a "spread evenly" plan for anti-affinity VMs, done if all the rest VMs got planned using binpack, otherwise continue. 2. Try to get a "no breach" plan for anti-affinity VMs, done if all the rest VMs got planned using binpack, otherwise continue. 3. Carry out a binpack plan ignoring VM anti-affinity. Signed-off-by: Gang Ji --- ocaml/xapi/xapi_ha_vm_failover.ml | 449 +++++++++++++++++++++++++++--- 1 file changed, 408 insertions(+), 41 deletions(-) diff --git a/ocaml/xapi/xapi_ha_vm_failover.ml b/ocaml/xapi/xapi_ha_vm_failover.ml index 4fbf46860f2..d52fcc1c641 100644 --- a/ocaml/xapi/xapi_ha_vm_failover.ml +++ b/ocaml/xapi/xapi_ha_vm_failover.ml @@ -175,9 +175,6 @@ let order_f (_, vm_rec) = let ( $ ) x y = x y -(*****************************************************************************************************) -(* Planning code follows *) - (* Compute the total memory required of a VM (Running or not) *) let total_memory_of_vm ~__context policy snapshot = let main, shadow = @@ -185,50 +182,411 @@ let total_memory_of_vm ~__context policy snapshot = in Int64.add main shadow -(** Return a VM -> Host plan for the Host.evacuate code. We assume the VMs are all agile. The returned plan may - be incomplete if there was not enough memory. *) -let compute_evacuation_plan ~__context total_hosts remaining_hosts - vms_and_snapshots = - let hosts = - List.map - (fun host -> - ( host - , Memory_check.host_compute_free_memory_with_maximum_compression - ~__context ~host None - ) - ) - remaining_hosts +let host_free_memory ~__context ~host = + Memory_check.host_compute_free_memory_with_maximum_compression ~__context + ~host None + +let vm_memory ~__context snapshot = + let policy = + match Helpers.check_domain_type snapshot.API.vM_domain_type with + | `hvm | `pv -> + Memory_check.Dynamic_min + | `pv_in_pvh | `pvh -> + Memory_check.Static_max in - let vms = - List.map - (fun (vm, snapshot) -> - let policy = - match Helpers.check_domain_type snapshot.API.vM_domain_type with - | `hvm | `pv -> - Memory_check.Dynamic_min - | `pv_in_pvh | `pvh -> - Memory_check.Static_max + total_memory_of_vm ~__context policy snapshot + +module VMGrpRefOrd = struct + type t = [`VM_group] Ref.t + + let compare = Ref.compare +end + +module VMGrpMap = Map.Make (VMGrpRefOrd) + +module HostKey = struct + type t = [`host] Ref.t + + let compare = Ref.compare +end + +(* For a VM anti-affinity group, the state of a host which determines + evacuation planning for anti-affinity VMs in that group: + 1. vm_cnt: the number of running VMs in that group resident on the host + 2. h_size: the amount of free memory of the host *) +module HostStatistics = struct + type t = {vm_cnt: int; h_size: int64} + + (* During evacuation planning for anti-affinity VMs, "vm_cnt" is the first + factor considered, "h_size" is the second factor considered: + Let's say the next anti-affinity VM to be planned belongs to group A, the + host to be selected should be the one which has minimal "vm_cnt" of group + A, for hosts with the same "vm_cnt", pick the one with the minimal + "h_size" which can hold the VM(h_size >= vm_size). *) + let compare {vm_cnt= vm_cnt_0; h_size= h_size_0} + {vm_cnt= vm_cnt_1; h_size= h_size_1} = + match Int.compare vm_cnt_0 vm_cnt_1 with + | 0 -> + Int64.compare h_size_0 h_size_1 + | c -> + c +end + +(* A Psq of hosts for an anti-affinity group, which is used for evacuation + planning for anti-affinity VMs in that group: the minimal host in this Psq + is the first one to be considered to plan a VM from that group. + When several hosts share the minimal "HostStatistics", + the minimal host is the host with the smallest ref. *) +module AntiAffEvacPlanHostPsq = Psq.Make (HostKey) (HostStatistics) + +(* The spread evenly plan pool state determines the spread evenly evacuation + planning for anti-affinity VMs. + It's a VMGrpMap which contains a Psq for each group, and each Psq contains + all the available hosts in the pool. + Let's say the anti-affinity VM to be planned belongs to anti-affinity group + A. To get a spread evenly evacuation plan, the most suitable host to plan + the VM would be the host which has the minimal number of running VMs from + group A resident on it, for the hosts with the same number of running VMs + from group A, the one with the minimal free memory will be checked first, + which is just the minimal host returned from "Psq.min" on the Psq of group + A. *) +let init_spread_evenly_plan_pool_state ~__context anti_aff_vms hosts = + let module Q = AntiAffEvacPlanHostPsq in + let gen_psq grp = + let module H = Xapi_vm_helpers in + let host_vm_cnt = H.host_to_vm_count_map ~__context grp in + List.fold_left + (fun q (h, h_size) -> + let vm_cnt = + H.HostMap.find_opt h host_vm_cnt |> Option.value ~default:0 in - (vm, total_memory_of_vm ~__context policy snapshot) + Q.add h {vm_cnt; h_size} q ) - vms_and_snapshots + Q.empty hosts in + let module VMGrpSet = Set.Make (VMGrpRefOrd) in + anti_aff_vms |> List.map (fun (_, _, grp) -> grp) |> VMGrpSet.of_list + |> fun s -> + VMGrpSet.fold + (fun grp grp_psq -> VMGrpMap.add grp (gen_psq grp) grp_psq) + s VMGrpMap.empty + +(* Update "spread_evenly_plan_pool_state" after a VM from anti-affinity "group" + with memory size: "vm_size" is planned on the "host": + 1. For the "group", increase "vm_cnt" of the "host" by 1. + 2. For each group, updates the host's size by substracting "vm_size". *) +let update_spread_evenly_plan_pool_state vm_size group host pool_state = + let module Q = AntiAffEvacPlanHostPsq in + VMGrpMap.mapi + (fun grp hosts_q -> + Q.adjust host + (fun {vm_cnt; h_size} -> + let h_size = Int64.sub h_size vm_size in + let vm_cnt = vm_cnt + if grp = group then 1 else 0 in + {vm_cnt; h_size} + ) + hosts_q + ) + pool_state + +(* The no breach plan pool state determines the no breach evacuation planning + for anti-affinity VMs. + It's a VMGrpMap which contains "no breach plan state" for each VM anti- + affinity group. + "no breach plan state" has 2 elements: + 1. a Psq which contains "no_resident" hosts for that group. (A "no + resident" host for a group is a host which has no running VMs from that + group resident on it.) + 2. an int which is the number of "resident" hosts for each group. (A + "resident" host for a group is a host which has at least one running VM + from that group resident on it.) + Let's say the anti-affinity VM to be planned belongs to anti-affinity group + A. If for group A, the number of "resident" hosts is already 2 or greater + than 2, then we don't need to plan the VM on any host, if not, we will need + to check the host with the minimal free memory from the "no resident" hosts + queue, which is just the minimal host returned from "Psq.min" on the "no + resident" hosts Psq of group A. *) +let init_no_breach_plan_pool_state spread_evenly_plan_pool_state = + let module Q = AntiAffEvacPlanHostPsq in + spread_evenly_plan_pool_state + |> VMGrpMap.map (fun hs -> + let no_resident_hosts, resident_hosts = + Q.partition (fun _ {vm_cnt; _} -> vm_cnt = 0) hs + in + (no_resident_hosts, Q.size resident_hosts) + ) + +(* Update "no_breach_plan_pool_state" after a VM from anti-affinity "group" + with memory size: "vm_size" is planned on the "host": + 1. For the "group", the "host" is removed from its "no_resident" hosts + queue, and increase its "resident_hosts_cnt" by 1. + 2. For other groups, updates the host's size by substracting "vm_size" if + the host is in that group's "no_resident" hosts queue. *) +let update_no_breach_plan_pool_state vm_size group host pool_state = + let module Q = AntiAffEvacPlanHostPsq in + VMGrpMap.mapi + (fun grp (no_resident_hosts, resident_hosts_cnt) -> + match grp = group with + | true -> + (Q.remove host no_resident_hosts, succ resident_hosts_cnt) + | false -> + let open HostStatistics in + ( Q.update host + (Option.map (fun {vm_cnt; h_size} -> + {vm_cnt; h_size= Int64.sub h_size vm_size} + ) + ) + no_resident_hosts + , resident_hosts_cnt + ) + ) + pool_state + +(* For an anti-affinity group, select host for a VM of memory size: vm_size + from hosts Psq: hosts_psq, returns the selected host for the VM and the + available hosts Psq for the remaining VMs to be planned in that anti- + affinity group. *) +let rec select_host_for_anti_aff_evac_plan vm_size hosts_psq = + let module Q = AntiAffEvacPlanHostPsq in + match Q.pop hosts_psq with + | None -> + None + | Some ((host, {vm_cnt= _; h_size}), rest_hosts) -> ( + match vm_size <= h_size with + | true -> + (* "host", the minimal one in "hosts_psq", might still be able to hold + the next VM: if its free memory, after the current VM is placed on + it, is still larger than the size of the next VM *) + Some (host, hosts_psq) + | false -> + (* "host" will not be available for the remaining VMs as the anti- + affinity VMs to be planned are sorted increasingly in terms of their + size, since the host can't hold current VM, it will not be able to + hold the next VM. *) + select_host_for_anti_aff_evac_plan vm_size rest_hosts + ) + +let impossible_error_handler () = + let msg = "Data corrupted during host evacuation." in + error "%s" msg ; + raise (Api_errors.Server_error (Api_errors.internal_error, [msg])) + +(*****************************************************************************************************) +(* Planning code follows *) + +(* Try to get a spread evenly plan for anti-affinity VMs (for each anti- + affinity group, the number of running VMs from that group are spread evenly + in all the rest hosts in the pool): + 1. For all the anti-affinity VMs which sorted in an increasing order in + terms of the VM's memory size, do host selection as below step 2. + 2. For each anti-affinity VM, select a host which can run it, and which has + the minimal number of VMs in the same anti-affinity group running on it, + for the hosts with the same number of running VMs in that group, pick the + one with the minimal free memory. *) +let compute_spread_evenly_plan ~__context pool_state anti_aff_vms = + info "compute_spread_evenly_plan" ; + List.fold_left + (fun (acc_mapping, acc_pool_state) (vm, vm_size, group) -> + debug "Spread evenly plan: try to plan for anti-affinity VM (%s %s %s)." + (Ref.string_of vm) + (Db.VM.get_name_label ~__context ~self:vm) + (Db.VM_group.get_name_label ~__context ~self:group) ; + match + VMGrpMap.find group acc_pool_state + |> select_host_for_anti_aff_evac_plan vm_size + with + | None -> + debug + "Spread evenly plan: no host can hold this anti-affinity VM. Stop \ + the planning as there won't be a valid plan for this VM." ; + ([], VMGrpMap.empty) + | Some (h, avail_hosts_for_group) -> + debug + "Spread evenly plan: choose the host with the minimal free memory \ + which can run the vm: (%s %s)." + (Ref.string_of h) + (Db.Host.get_name_label ~__context ~self:h) ; + ( (vm, h) :: acc_mapping + , acc_pool_state + |> VMGrpMap.update group (fun _ -> Some avail_hosts_for_group) + |> update_spread_evenly_plan_pool_state vm_size group h + ) + | exception Not_found -> + impossible_error_handler () + ) + ([], pool_state) anti_aff_vms + |> fst + +(* Try to get a no breach plan for anti-affinity VMs (for each anti-affinity + group, there are at least 2 hosts having running VMs in the group): + 1. For all the anti-affinity VMs which sorted in an increasing order in + terms of the VM's memory size, do host selection as below step 2. + 2. For each anti-affinity VM, try to select a host for it so that there are + at least 2 hosts which has running VMs in the same anti-affinity group. + If there are already 2 hosts having running VMs in that group, skip + planning for the VM. *) +let compute_no_breach_plan ~__context pool_state anti_aff_vms = + info "compute_no_breach_plan" ; + List.fold_left + (fun (acc_mapping, acc_not_planned_vms, acc_pool_state) (vm, vm_size, group) -> + debug "No breach plan: try to plan for anti-affinity VM (%s %s %s)." + (Ref.string_of vm) + (Db.VM.get_name_label ~__context ~self:vm) + (Db.VM_group.get_name_label ~__context ~self:group) ; + + match VMGrpMap.find group acc_pool_state with + | no_resident_hosts, resident_hosts_cnt when resident_hosts_cnt < 2 -> ( + debug + "No breach plan: there are less than 2 hosts has running VM in the \ + same anti-affinity group, and there are still host(s) which has 0 \ + running VMs, try to plan for it." ; + match + select_host_for_anti_aff_evac_plan vm_size no_resident_hosts + with + | None -> + debug + "No breach plan: failed to select host on any of the no \ + resident hosts, skip it, continue with the next VM." ; + (acc_mapping, (vm, vm_size) :: acc_not_planned_vms, acc_pool_state) + | Some (h, hosts) -> + debug + "No breach plan: choose the no resident host with the minimal \ + free memory which can run the vm: (%s)." + (Db.Host.get_name_label ~__context ~self:h) ; + ( (vm, h) :: acc_mapping + , acc_not_planned_vms + , acc_pool_state + |> VMGrpMap.update group (Option.map (fun (_, i) -> (hosts, i))) + |> update_no_breach_plan_pool_state vm_size group h + ) + ) + | exception Not_found -> + impossible_error_handler () + | _ -> + debug + "No breach plan: no need to plan for the VM as the number of hosts \ + which has running VMs from the same group is no less than 2, \ + continue to plan for the next one." ; + (acc_mapping, (vm, vm_size) :: acc_not_planned_vms, acc_pool_state) + ) + ([], [], pool_state) anti_aff_vms + |> fun (plan, not_planned_vms, _) -> (plan, not_planned_vms) + +let vms_partition ~__context vms = + vms + |> List.partition_map (fun (vm, vm_size) -> + match Xapi_vm_helpers.vm_has_anti_affinity ~__context ~vm with + | Some (`AntiAffinity group) -> + Either.Left (vm, vm_size, group) + | _ -> + Either.Right (vm, vm_size) + ) + +(* Return an evacuation plan respecting VM anti-affinity rules: it is done in 3 + phases: + 1. Try to get a "spread evenly" plan for anti-affinity VMs, and then a + binpack plan for the rest of VMs. Done if every VM got planned, otherwise + continue. + 2. Try to get a "no breach" plan for anti-affinity VMs, and then a binpack + plan for the rest of VMs. Done if every VM got planned, otherwise + continue. + 3. Carry out a binpack plan ignoring VM anti-affinity. *) +let compute_anti_aff_evac_plan ~__context total_hosts hosts vms = let config = {Binpack.hosts; vms; placement= []; total_hosts; num_failures= 1} in Binpack.check_configuration config ; - debug "Planning configuration for offline agile VMs = %s" - (Binpack.string_of_configuration - (fun x -> - Printf.sprintf "%s (%s)" (Ref.short_string_of x) - (Db.Host.get_hostname ~__context ~self:x) - ) - (fun x -> - Printf.sprintf "%s (%s)" (Ref.short_string_of x) - (Db.VM.get_name_label ~__context ~self:x) - ) - config - ) ; + + let binpack_plan ~__context config vms = + debug "Binpack planning configuration = %s" + (Binpack.string_of_configuration + (fun x -> + Printf.sprintf "%s (%s)" (Ref.short_string_of x) + (Db.Host.get_name_label ~__context ~self:x) + ) + (fun x -> + Printf.sprintf "%s (%s)" (Ref.short_string_of x) + (Db.VM.get_name_label ~__context ~self:x) + ) + config + ) ; + debug "VMs to attempt to evacuate: [ %s ]" + (String.concat "; " + (vms + |> List.map (fun (self, _) -> + Printf.sprintf "%s (%s)" (Ref.short_string_of self) + (Db.VM.get_name_label ~__context ~self) + ) + ) + ) ; + let h = Binpack.choose_heuristic config in + h.Binpack.get_specific_plan config (List.map fst vms) + in + + let binpack_after_plan_applied plan not_planned_vms = + match plan with + | [] -> + None + | plan -> ( + debug "Binpack for the rest VMs" ; + let config_after_plan_applied = Binpack.apply_plan config plan in + let config_after_plan_applied = + {config_after_plan_applied with vms= not_planned_vms} + in + let b_plan = + binpack_plan ~__context config_after_plan_applied not_planned_vms + in + match List.length b_plan = List.length not_planned_vms with + | true -> + debug "Got final plan." ; + Some (plan @ b_plan) + | false -> + debug + "Failed to get final plan as failed to binpack for all the rest \ + VMs." ; + None + ) + in + + match total_hosts with + | h when h < 3 -> + debug + "There are less than 2 available hosts to migrate VMs to, \ + anti-affinity evacuation plan is not needed." ; + binpack_plan ~__context config vms + | _ -> + let anti_aff_vms, non_anti_aff_vms = vms |> vms_partition ~__context in + let spread_evenly_plan_pool_state = + init_spread_evenly_plan_pool_state ~__context anti_aff_vms hosts + in + let anti_aff_vms_increasing = + anti_aff_vms |> List.sort (fun (_, a, _) (_, b, _) -> compare a b) + in + + let ( let* ) o f = match o with None -> f None | p -> p in + (let* _no_plan = + let plan = + compute_spread_evenly_plan ~__context spread_evenly_plan_pool_state + anti_aff_vms_increasing + in + binpack_after_plan_applied plan non_anti_aff_vms + in + let* _no_plan = + let plan, not_planned_vms = + compute_no_breach_plan ~__context + (init_no_breach_plan_pool_state spread_evenly_plan_pool_state) + anti_aff_vms_increasing + in + binpack_after_plan_applied plan (non_anti_aff_vms @ not_planned_vms) + in + binpack_plan ~__context config vms |> Option.some + ) + |> Option.value ~default:[] + +(** Return a VM -> Host plan for the Host.evacuate code. We assume the VMs are all agile. The returned plan may + be incomplete if there was not enough memory. *) +let compute_evacuation_plan ~__context total_hosts remaining_hosts + vms_and_snapshots = debug "VMs to attempt to evacuate: [ %s ]" (String.concat "; " (List.map @@ -239,8 +597,17 @@ let compute_evacuation_plan ~__context total_hosts remaining_hosts vms_and_snapshots ) ) ; - let h = Binpack.choose_heuristic config in - h.Binpack.get_specific_plan config (List.map fst vms_and_snapshots) + let hosts = + List.map + (fun host -> (host, host_free_memory ~__context ~host)) + remaining_hosts + in + let vms = + List.map + (fun (vm, snapshot) -> (vm, vm_memory ~__context snapshot)) + vms_and_snapshots + in + compute_anti_aff_evac_plan ~__context total_hosts hosts vms (** Passed to the planner to reason about other possible configurations, used to block operations which would destroy the HA VM restart plan. *) From fcbab2bfd25967f5f4834d828fc0417754afedea Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Tue, 2 Apr 2024 10:51:21 +0800 Subject: [PATCH 17/44] CP-48752: Update UT Add "groups" "power_state" for VM, vm set_resident_on host Signed-off-by: Gang Ji --- ocaml/tests/test_ha_vm_failover.ml | 49 ++++++++++++++++++++++++++++-- 1 file changed, 46 insertions(+), 3 deletions(-) diff --git a/ocaml/tests/test_ha_vm_failover.ml b/ocaml/tests/test_ha_vm_failover.ml index 4ab377870ab..67adea440e4 100644 --- a/ocaml/tests/test_ha_vm_failover.ml +++ b/ocaml/tests/test_ha_vm_failover.ml @@ -27,6 +27,8 @@ type vbd = {agile: bool} type vif = {agile: bool} +type group = {name_label: string; placement: string} + type vm = { ha_always_run: bool ; ha_restart_priority: string @@ -34,6 +36,8 @@ type vm = { ; name_label: string ; vbds: vbd list ; vifs: vif list + ; groups: group list + ; power_state: string } let basic_vm = @@ -44,6 +48,8 @@ let basic_vm = ; name_label= "vm" ; vbds= [{agile= true}] ; vifs= [{agile= true}] + ; groups= [] + ; power_state= "running" } type host = {memory_total: int64; name_label: string; vms: vm list} @@ -55,8 +61,13 @@ type pool = { ; cluster: int } -let string_of_vm {memory; name_label; _} = - Printf.sprintf "{memory = %Ld; name_label = %S}" memory name_label +let string_of_group {name_label; placement} = + Printf.sprintf "{name_label = %S; placement = %S}" name_label placement + +let string_of_vm {memory; name_label; groups; _} = + Printf.sprintf "{memory = %Ld; name_label = %S; groups = [%s]}" memory + name_label + (Test_printers.list string_of_group groups) let string_of_host {memory_total; name_label; vms} = Printf.sprintf "{memory_total = %Ld; name_label = %S; vms = [%s]}" @@ -71,6 +82,26 @@ let string_of_pool {master; slaves; ha_host_failures_to_tolerate; cluster} = (Test_printers.list string_of_host slaves) ha_host_failures_to_tolerate cluster +let load_group ~__context ~group = + let placement = + match group.placement with + | "anti_affinity" -> + `anti_affinity + | _ -> + `normal + in + match + Db.VM_group.get_all ~__context + |> List.find_opt (fun g -> + Db.VM_group.get_name_label ~__context ~self:g = group.name_label + && Db.VM_group.get_placement ~__context ~self:g = placement + ) + with + | None -> + make_vm_group ~__context ~name_label:group.name_label ~placement () + | Some g -> + g + let load_vm ~__context ~(vm : vm) ~local_sr ~shared_sr ~local_net ~shared_net = let vm_ref = make_vm ~__context ~ha_always_run:vm.ha_always_run @@ -98,6 +129,14 @@ let load_vm ~__context ~(vm : vm) ~local_sr ~shared_sr ~local_net ~shared_net = ) vm.vbds in + let groups = + List.fold_left + (fun acc group -> load_group ~__context ~group :: acc) + [] vm.groups + in + Db.VM.set_groups ~__context ~self:vm_ref ~value:groups ; + if "running" = vm.power_state then + Db.VM.set_power_state ~__context ~self:vm_ref ~value:`Running ; vm_ref let load_host ~__context ~host ~local_sr ~shared_sr ~local_net ~shared_net = @@ -110,7 +149,11 @@ let load_host ~__context ~host ~local_sr ~shared_sr ~local_net ~shared_net = let (_ : API.ref_VM list) = List.map (fun vm -> - load_vm ~__context ~vm ~local_sr ~shared_sr ~local_net ~shared_net + let vm_ref = + load_vm ~__context ~vm ~local_sr ~shared_sr ~local_net ~shared_net + in + Db.VM.set_resident_on ~__context ~self:vm_ref ~value:host_ref ; + vm_ref ) host.vms in From c626cdb2604bdf888ef5300d115e2d515dae15e0 Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Wed, 29 May 2024 15:29:01 +0800 Subject: [PATCH 18/44] CP-48752: Add UT for host evacuation with anti-affinity support Signed-off-by: Gang Ji --- ocaml/tests/test_ha_vm_failover.ml | 883 +++++++++++++++++++++++++++-- ocaml/xapi/xapi_ha_vm_failover.mli | 48 ++ 2 files changed, 880 insertions(+), 51 deletions(-) diff --git a/ocaml/tests/test_ha_vm_failover.ml b/ocaml/tests/test_ha_vm_failover.ml index 67adea440e4..fe915563e18 100644 --- a/ocaml/tests/test_ha_vm_failover.ml +++ b/ocaml/tests/test_ha_vm_failover.ml @@ -27,7 +27,9 @@ type vbd = {agile: bool} type vif = {agile: bool} -type group = {name_label: string; placement: string} +type placement_policy = AntiAffinity | Normal + +type group = {name_label: string; placement: placement_policy} type vm = { ha_always_run: bool @@ -61,8 +63,62 @@ type pool = { ; cluster: int } +let master = "master" + +let slave = "slave" + +let slave1 = "slave1" + +let slave2 = "slave2" + +let slave3 = "slave3" + +let grp1 = "grp1" + +let grp2 = "grp2" + +(** vmX_grpY: in test case for anti_affinity, the VM is the Xth smallest of slave1's VMs of + the same placement type in terms of VM's memory size, and it belows to VM group: grpY. *) +let vm1_grp1 = "vm1_grp1" + +let vm2_grp1 = "vm2_grp1" + +let vm3_grp1 = "vm3_grp1" + +let vm4_grp1 = "vm4_grp1" + +let vm5_grp1 = "vm5_grp1" + +let vm6_grp1 = "vm6_grp1" + +let vm8_grp1 = "vm8_grp1" + +let vm2_grp2 = "vm2_grp2" + +let vm3_grp2 = "vm3_grp2" + +let vm4_grp2 = "vm4_grp2" + +let vm5_grp2 = "vm5_grp2" + +let vm7_grp2 = "vm7_grp2" + +(** In test case for anti_affinity, it is a VM resident on host other than slave1 *) +let vm_grp1 = "vm_grp1" + +(** vmX: in test case for anti_affinity, it is a VM not in any VM group, and it is the Xth + largest of slave1's VMs not in any VM group in terms of VM's memory size. *) +let vm1 = "vm1" + +let vm2 = "vm2" + +let vm3 = "vm3" + +let vm4 = "vm4" + let string_of_group {name_label; placement} = - Printf.sprintf "{name_label = %S; placement = %S}" name_label placement + Printf.sprintf "{name_label = %S; placement = %S}" name_label + (match placement with AntiAffinity -> "anti_affinity" | Normal -> "normal") let string_of_vm {memory; name_label; groups; _} = Printf.sprintf "{memory = %Ld; name_label = %S; groups = [%s]}" memory @@ -85,9 +141,9 @@ let string_of_pool {master; slaves; ha_host_failures_to_tolerate; cluster} = let load_group ~__context ~group = let placement = match group.placement with - | "anti_affinity" -> + | AntiAffinity -> `anti_affinity - | _ -> + | Normal -> `normal in match @@ -227,7 +283,7 @@ module AllProtectedVms = Generic.MakeStateful (struct [ (* No VMs and a single host. *) ( { - master= {memory_total= gib 256L; name_label= "master"; vms= []} + master= {memory_total= gib 256L; name_label= master; vms= []} ; slaves= [] ; ha_host_failures_to_tolerate= 0L ; cluster= 0 @@ -239,7 +295,7 @@ module AllProtectedVms = Generic.MakeStateful (struct master= { memory_total= gib 256L - ; name_label= "master" + ; name_label= master ; vms= [ {basic_vm with ha_always_run= false; ha_restart_priority= ""} @@ -256,7 +312,7 @@ module AllProtectedVms = Generic.MakeStateful (struct master= { memory_total= gib 256L - ; name_label= "master" + ; name_label= master ; vms= [{basic_vm with ha_always_run= false}] } ; slaves= [] @@ -267,8 +323,7 @@ module AllProtectedVms = Generic.MakeStateful (struct ) ; (* One protected VM. *) ( { - master= - {memory_total= gib 256L; name_label= "master"; vms= [basic_vm]} + master= {memory_total= gib 256L; name_label= master; vms= [basic_vm]} ; slaves= [] ; ha_host_failures_to_tolerate= 0L ; cluster= 0 @@ -280,15 +335,15 @@ module AllProtectedVms = Generic.MakeStateful (struct master= { memory_total= gib 256L - ; name_label= "master" + ; name_label= master ; vms= [ - {basic_vm with name_label= "vm1"} + {basic_vm with name_label= vm1} ; { basic_vm with ha_always_run= false ; ha_restart_priority= "" - ; name_label= "vm2" + ; name_label= vm2 } ] } @@ -296,7 +351,7 @@ module AllProtectedVms = Generic.MakeStateful (struct ; ha_host_failures_to_tolerate= 0L ; cluster= 0 } - , ["vm1"] + , [vm1] ) ] end) @@ -336,8 +391,8 @@ module PlanForNFailures = Generic.MakeStateful (struct [ (* Two host pool with no VMs. *) ( { - master= {memory_total= gib 256L; name_label= "master"; vms= []} - ; slaves= [{memory_total= gib 256L; name_label= "slave"; vms= []}] + master= {memory_total= gib 256L; name_label= master; vms= []} + ; slaves= [{memory_total= gib 256L; name_label= slave; vms= []}] ; ha_host_failures_to_tolerate= 1L ; cluster= 0 } @@ -349,10 +404,10 @@ module PlanForNFailures = Generic.MakeStateful (struct master= { memory_total= gib 256L - ; name_label= "master" - ; vms= [{basic_vm with memory= gib 120L; name_label= "vm1"}] + ; name_label= master + ; vms= [{basic_vm with memory= gib 120L; name_label= vm1}] } - ; slaves= [{memory_total= gib 256L; name_label= "slave"; vms= []}] + ; slaves= [{memory_total= gib 256L; name_label= slave; vms= []}] ; ha_host_failures_to_tolerate= 1L ; cluster= 0 } @@ -363,14 +418,14 @@ module PlanForNFailures = Generic.MakeStateful (struct master= { memory_total= gib 256L - ; name_label= "master" + ; name_label= master ; vms= [ - {basic_vm with memory= gib 120L; name_label= "vm1"} - ; {basic_vm with memory= gib 120L; name_label= "vm2"} + {basic_vm with memory= gib 120L; name_label= vm1} + ; {basic_vm with memory= gib 120L; name_label= vm2} ] } - ; slaves= [{memory_total= gib 256L; name_label= "slave"; vms= []}] + ; slaves= [{memory_total= gib 256L; name_label= slave; vms= []}] ; ha_host_failures_to_tolerate= 1L ; cluster= 0 } @@ -381,22 +436,22 @@ module PlanForNFailures = Generic.MakeStateful (struct master= { memory_total= gib 256L - ; name_label= "master" + ; name_label= master ; vms= [ - {basic_vm with memory= gib 120L; name_label= "vm1"} - ; {basic_vm with memory= gib 120L; name_label= "vm2"} + {basic_vm with memory= gib 120L; name_label= vm1} + ; {basic_vm with memory= gib 120L; name_label= vm2} ] } ; slaves= [ { memory_total= gib 256L - ; name_label= "slave" + ; name_label= slave ; vms= [ - {basic_vm with memory= gib 120L; name_label= "vm3"} - ; {basic_vm with memory= gib 120L; name_label= "vm4"} + {basic_vm with memory= gib 120L; name_label= vm3} + ; {basic_vm with memory= gib 120L; name_label= vm4} ] } ] @@ -465,10 +520,10 @@ module AssertNewVMPreservesHAPlan = Generic.MakeStateful (struct master= { memory_total= gib 256L - ; name_label= "master" - ; vms= [{basic_vm with memory= gib 120L; name_label= "vm1"}] + ; name_label= master + ; vms= [{basic_vm with memory= gib 120L; name_label= vm1}] } - ; slaves= [{memory_total= gib 256L; name_label= "slave"; vms= []}] + ; slaves= [{memory_total= gib 256L; name_label= slave; vms= []}] ; ha_host_failures_to_tolerate= 1L ; cluster= 0 } @@ -477,7 +532,7 @@ module AssertNewVMPreservesHAPlan = Generic.MakeStateful (struct ha_always_run= false ; ha_restart_priority= "restart" ; memory= gib 120L - ; name_label= "vm2" + ; name_label= vm2 } ) , Ok () @@ -488,14 +543,14 @@ module AssertNewVMPreservesHAPlan = Generic.MakeStateful (struct master= { memory_total= gib 256L - ; name_label= "master" + ; name_label= master ; vms= [ - {basic_vm with memory= gib 120L; name_label= "vm1"} - ; {basic_vm with memory= gib 120L; name_label= "vm2"} + {basic_vm with memory= gib 120L; name_label= vm1} + ; {basic_vm with memory= gib 120L; name_label= vm2} ] } - ; slaves= [{memory_total= gib 256L; name_label= "slave"; vms= []}] + ; slaves= [{memory_total= gib 256L; name_label= slave; vms= []}] ; ha_host_failures_to_tolerate= 1L ; cluster= 0 } @@ -504,7 +559,7 @@ module AssertNewVMPreservesHAPlan = Generic.MakeStateful (struct ha_always_run= false ; ha_restart_priority= "restart" ; memory= gib 120L - ; name_label= "vm2" + ; name_label= vm2 } ) , Error @@ -518,19 +573,19 @@ module AssertNewVMPreservesHAPlan = Generic.MakeStateful (struct master= { memory_total= gib 256L - ; name_label= "master" + ; name_label= master ; vms= [ - {basic_vm with memory= gib 120L; name_label= "vm1"} - ; {basic_vm with memory= gib 120L; name_label= "vm2"} + {basic_vm with memory= gib 120L; name_label= vm1} + ; {basic_vm with memory= gib 120L; name_label= vm2} ] } ; slaves= [ { memory_total= gib 256L - ; name_label= "slave" - ; vms= [{basic_vm with memory= gib 120L; name_label= "vm1"}] + ; name_label= slave + ; vms= [{basic_vm with memory= gib 120L; name_label= vm1}] } ] ; ha_host_failures_to_tolerate= 1L @@ -541,7 +596,7 @@ module AssertNewVMPreservesHAPlan = Generic.MakeStateful (struct ha_always_run= false ; ha_restart_priority= "restart" ; memory= gib 120L - ; name_label= "vm2" + ; name_label= vm2 } ) , Ok () @@ -576,11 +631,11 @@ module ComputeMaxFailures = Generic.MakeStateful (struct [ (* Three host pool with no VMs. *) ( { - master= {memory_total= gib 256L; name_label= "master"; vms= []} + master= {memory_total= gib 256L; name_label= master; vms= []} ; slaves= [ - {memory_total= gib 256L; name_label= "slave1"; vms= []} - ; {memory_total= gib 256L; name_label= "slave2"; vms= []} + {memory_total= gib 256L; name_label= slave1; vms= []} + ; {memory_total= gib 256L; name_label= slave2; vms= []} ] ; (* Placeholder value that is overridden when we call the compute function *) ha_host_failures_to_tolerate= 3L @@ -591,8 +646,8 @@ module ComputeMaxFailures = Generic.MakeStateful (struct ) ; (* Two hosts pool with no VMs *) ( { - master= {memory_total= gib 256L; name_label= "master"; vms= []} - ; slaves= [{memory_total= gib 256L; name_label= "slave1"; vms= []}] + master= {memory_total= gib 256L; name_label= master; vms= []} + ; slaves= [{memory_total= gib 256L; name_label= slave1; vms= []}] ; ha_host_failures_to_tolerate= 2L ; cluster= 2 } @@ -601,8 +656,8 @@ module ComputeMaxFailures = Generic.MakeStateful (struct ) ; (* Two host pool with one down *) ( { - master= {memory_total= gib 256L; name_label= "master"; vms= []} - ; slaves= [{memory_total= gib 256L; name_label= "slave1"; vms= []}] + master= {memory_total= gib 256L; name_label= master; vms= []} + ; slaves= [{memory_total= gib 256L; name_label= slave1; vms= []}] ; ha_host_failures_to_tolerate= 2L ; cluster= 1 } @@ -612,4 +667,730 @@ module ComputeMaxFailures = Generic.MakeStateful (struct ] end) -let tests = [("plan_for_n_failures", PlanForNFailures.tests)] +let extract_output_for_anti_aff_plan ~__context plan = + plan + |> List.map (fun (vm, host) -> + ( Db.VM.get_name_label ~__context ~self:vm + , Db.Host.get_name_label ~__context ~self:host + ) + ) + +let anti_aff_grp1 = {name_label= grp1; placement= AntiAffinity} + +let anti_aff_plan_test_cases = + [ + (* Test 0: No VMs in slave1 to be evacuated. *) + ( { + master= {memory_total= gib 256L; name_label= master; vms= []} + ; slaves= + [ + {memory_total= gib 256L; name_label= slave1; vms= []} + ; {memory_total= gib 256L; name_label= slave2; vms= []} + ] + ; ha_host_failures_to_tolerate= 0L + ; cluster= 0 + } + , (* Assert that spread_evenly_plan returns as expected *) + [] + , (* Assert that no_breach_plan returns as expected *) + [] + ) + ; (* Test 1: No anti-affinity VMs in slave1 to be evacuated *) + ( { + master= {memory_total= gib 256L; name_label= master; vms= []} + ; slaves= + [ + { + memory_total= gib 256L + ; name_label= slave1 + ; vms= + [ + {basic_vm with memory= gib 120L; name_label= vm1} + ; {basic_vm with memory= gib 120L; name_label= vm2} + ] + } + ; {memory_total= gib 256L; name_label= slave2; vms= []} + ] + ; ha_host_failures_to_tolerate= 0L + ; cluster= 0 + } + , (* Assert that spread_evenly_plan returns as expected *) + [] + , (* Assert that no_breach_plan returns as expected *) + [] + ) + ; (* Test 2: One anti-affinity VM in slave1 to be evacuated *) + ( { + master= {memory_total= gib 512L; name_label= master; vms= []} + ; slaves= + [ + { + memory_total= gib 256L + ; name_label= slave1 + ; vms= + [ + { + basic_vm with + memory= gib 120L + ; name_label= vm1_grp1 + ; groups= [anti_aff_grp1] + } + ; {basic_vm with memory= gib 120L; name_label= vm1} + ] + } + ; {memory_total= gib 256L; name_label= slave2; vms= []} + ] + ; ha_host_failures_to_tolerate= 0L + ; cluster= 0 + } + , (* Assert that spread_evenly_plan returns as expected *) + [(vm1_grp1, slave2)] + , (* Assert that no_breach_plan returns as expected *) + [(vm1_grp1, slave2)] + ) + ; (* Test 3: One anti-affinity VM in slave1 to be evacuated, the smallest host already has anti-affinity VM in the same group *) + ( { + master= {memory_total= gib 512L; name_label= master; vms= []} + ; slaves= + [ + { + memory_total= gib 256L + ; name_label= slave1 + ; vms= + [ + { + basic_vm with + memory= gib 120L + ; name_label= vm1_grp1 + ; groups= [anti_aff_grp1] + } + ; {basic_vm with memory= gib 120L; name_label= "vm2"} + ] + } + ; { + memory_total= gib 256L + ; name_label= slave2 + ; vms= + [ + { + basic_vm with + memory= gib 120L + ; name_label= vm_grp1 + ; groups= [anti_aff_grp1] + } + ] + } + ] + ; ha_host_failures_to_tolerate= 0L + ; cluster= 0 + } + , (* Assert that spread_evenly_plan returns as expected *) + [(vm1_grp1, master)] + , (* Assert that no_breach_plan returns as expected *) + [(vm1_grp1, master)] + ) + ; (* Test 4: Two anti-affinity VMs belong to one group in slave1 to be evacuated *) + ( { + master= {memory_total= gib 512L; name_label= master; vms= []} + ; slaves= + [ + { + memory_total= gib 256L + ; name_label= slave1 + ; vms= + [ + { + basic_vm with + memory= gib 120L + ; name_label= vm1_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 130L + ; name_label= vm2_grp1 + ; groups= [anti_aff_grp1] + } + ] + } + ; {memory_total= gib 256L; name_label= slave2; vms= []} + ] + ; ha_host_failures_to_tolerate= 0L + ; cluster= 0 + } + , (* Assert that spread_evenly_plan returns as expected *) + [(vm2_grp1, master); (vm1_grp1, slave2)] + , (* Assert that no_breach_plan returns as expected *) + [(vm2_grp1, master); (vm1_grp1, slave2)] + ) + ; (* Test 5: Two anti-affinity VMs belong to one group in slave1 to be evacuated, only 1 can be planed *) + ( { + master= {memory_total= gib 512L; name_label= master; vms= []} + ; slaves= + [ + { + memory_total= gib 256L + ; name_label= slave1 + ; vms= + [ + { + basic_vm with + memory= gib 120L + ; name_label= vm1_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 513L + ; name_label= vm2_grp1 + ; groups= [anti_aff_grp1] + } + ] + } + ; {memory_total= gib 256L; name_label= slave2; vms= []} + ] + ; ha_host_failures_to_tolerate= 0L + ; cluster= 0 + } + , (* Assert that spread_evenly_plan returns as expected *) + [] + , (* Assert that no_breach_plan returns as expected *) + [(vm1_grp1, slave2)] + ) + ; (* Test 6: 6 anti-affinity VMs belong to one group in slave1 to be evacuated, only 5 can be planned *) + ( { + master= {memory_total= gib 640L; name_label= master; vms= []} + ; slaves= + [ + { + memory_total= gib 256L + ; name_label= slave1 + ; vms= + [ + { + basic_vm with + memory= gib 120L + ; name_label= vm2_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 60L + ; name_label= vm1_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 400L + ; name_label= vm6_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 250L + ; name_label= vm4_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 260L + ; name_label= vm5_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 130L + ; name_label= vm3_grp1 + ; groups= [anti_aff_grp1] + } + ] + } + ; {memory_total= gib 256L; name_label= slave2; vms= []} + ] + ; ha_host_failures_to_tolerate= 0L + ; cluster= 0 + } + , (* Assert that spread_evenly_plan returns as expected *) + [] + , (* Assert that no_breach_plan returns as expected *) + [(vm2_grp1, master); (vm1_grp1, slave2)] + ) + ; (* Test 7: Two groups anti-affinity VMs in slave1 to be evacuated *) + ( { + master= {memory_total= gib 512L; name_label= master; vms= []} + ; slaves= + [ + { + memory_total= gib 256L + ; name_label= slave1 + ; vms= + [ + { + basic_vm with + memory= gib 120L + ; name_label= vm6_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 60L + ; name_label= vm5_grp2 + ; groups= [{name_label= grp2; placement= AntiAffinity}] + } + ; { + basic_vm with + memory= gib 130L + ; name_label= vm7_grp2 + ; groups= [{name_label= grp2; placement= AntiAffinity}] + } + ; { + basic_vm with + memory= gib 1L + ; name_label= vm1_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 2L + ; name_label= vm2_grp2 + ; groups= [{name_label= grp2; placement= AntiAffinity}] + } + ; { + basic_vm with + memory= gib 3L + ; name_label= vm3_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 4L + ; name_label= vm4_grp2 + ; groups= [{name_label= grp2; placement= AntiAffinity}] + } + ] + } + ; {memory_total= gib 256L; name_label= slave2; vms= []} + ] + ; ha_host_failures_to_tolerate= 0L + ; cluster= 0 + } + , (* Assert that spread_evenly_plan returns as expected *) + [ + (vm7_grp2, master) + ; (vm6_grp1, slave2) + ; (vm5_grp2, slave2) + ; (vm4_grp2, master) + ; (vm3_grp1, master) + ; (vm2_grp2, slave2) + ; (vm1_grp1, slave2) + ] + , (* Assert that no_breach_plan returns as expected *) + [ + (vm4_grp2, master) + ; (vm3_grp1, master) + ; (vm2_grp2, slave2) + ; (vm1_grp1, slave2) + ] + ) + ; (* Test 8: Two groups anti-affinity VMs in slave1 to be evacuated, master is bigger than slave2 in size when started, but becomes smaller during planning *) + ( { + master= {memory_total= gib 512L; name_label= master; vms= []} + ; slaves= + [ + { + memory_total= gib 256L + ; name_label= slave1 + ; vms= + [ + { + basic_vm with + memory= gib 120L + ; name_label= vm6_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 60L + ; name_label= vm5_grp2 + ; groups= [{name_label= grp2; placement= AntiAffinity}] + } + ; { + basic_vm with + memory= gib 130L + ; name_label= vm7_grp2 + ; groups= [{name_label= grp2; placement= AntiAffinity}] + } + ; { + basic_vm with + memory= gib 1L + ; name_label= vm1_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 6L + ; name_label= vm3_grp2 + ; groups= [{name_label= grp2; placement= AntiAffinity}] + } + ; { + basic_vm with + memory= gib 5L + ; name_label= vm2_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 7L + ; name_label= vm4_grp2 + ; groups= [{name_label= grp2; placement= AntiAffinity}] + } + ] + } + ; {memory_total= gib 510L; name_label= slave2; vms= []} + ] + ; ha_host_failures_to_tolerate= 0L + ; cluster= 0 + } + , (* Assert that spread_evenly_plan returns as expected *) + [ + (vm7_grp2, slave2) + ; (vm6_grp1, master) + ; (vm5_grp2, master) + ; (vm4_grp2, slave2) + ; (vm3_grp2, master) + ; (vm2_grp1, master) + ; (vm1_grp1, slave2) + ] + , (* Assert that no_breach_plan returns as expected *) + [ + (vm4_grp2, slave2) + ; (vm3_grp2, master) + ; (vm2_grp1, master) + ; (vm1_grp1, slave2) + ] + ) + ] + +module Slave1EvacuationVMAntiAffinitySpreadEvenlyPlan = +Generic.MakeStateful (struct + module Io = struct + type input_t = pool + + type output_t = (string * string) list + + let string_of_input_t = string_of_pool + + let string_of_output_t = Test_printers.(list (pair string string)) + end + + module State = Test_state.XapiDb + + let load_input __context = setup ~__context + + let extract_output __context _ = + let slv1 = + Db.Host.get_all ~__context + |> List.find (fun self -> Db.Host.get_name_label ~__context ~self = slave1) + in + let slave1_anti_aff_vms = + Db.Host.get_resident_VMs ~__context ~self:slv1 + |> List.map (fun self -> (self, Db.VM.get_record ~__context ~self)) + |> List.filter (fun (_, record) -> not record.API.vM_is_control_domain) + |> List.map (fun (self, record) -> + (self, Xapi_ha_vm_failover.vm_memory ~__context record) + ) + |> Xapi_ha_vm_failover.vms_partition ~__context + |> fst + in + let hosts = + Db.Host.get_all ~__context + |> List.filter (( <> ) slv1) + |> List.map (fun host -> + (host, Xapi_ha_vm_failover.host_free_memory ~__context ~host) + ) + in + let pool_state = + Xapi_ha_vm_failover.init_spread_evenly_plan_pool_state ~__context + slave1_anti_aff_vms hosts + in + extract_output_for_anti_aff_plan ~__context + (Xapi_ha_vm_failover.compute_spread_evenly_plan ~__context pool_state + (slave1_anti_aff_vms + |> List.sort (fun (_, a, _) (_, b, _) -> compare a b) + ) + ) + + let tests = + `QuickAndAutoDocumented + (anti_aff_plan_test_cases + |> List.map (fun (pool, spread_evenly_plan, _no_breach_plan) -> + (pool, spread_evenly_plan) + ) + ) +end) + +module Slave1EvacuationVMAntiAffinityNoBreachPlan = Generic.MakeStateful (struct + module Io = struct + type input_t = pool + + type output_t = (string * string) list + + let string_of_input_t = string_of_pool + + let string_of_output_t = Test_printers.(list (pair string string)) + end + + module State = Test_state.XapiDb + + let load_input __context = setup ~__context + + let extract_output __context _ = + let slv1 = + Db.Host.get_all ~__context + |> List.find (fun self -> Db.Host.get_name_label ~__context ~self = slave1) + in + let slave1_anti_aff_vms = + Db.Host.get_resident_VMs ~__context ~self:slv1 + |> List.map (fun self -> (self, Db.VM.get_record ~__context ~self)) + |> List.filter (fun (_, record) -> not record.API.vM_is_control_domain) + |> List.map (fun (self, record) -> + (self, Xapi_ha_vm_failover.vm_memory ~__context record) + ) + |> Xapi_ha_vm_failover.vms_partition ~__context + |> fst + in + let hosts = + Db.Host.get_all ~__context + |> List.filter (( <> ) slv1) + |> List.map (fun host -> + (host, Xapi_ha_vm_failover.host_free_memory ~__context ~host) + ) + in + let pool_state = + Xapi_ha_vm_failover.init_spread_evenly_plan_pool_state ~__context + slave1_anti_aff_vms hosts + |> Xapi_ha_vm_failover.init_no_breach_plan_pool_state + in + extract_output_for_anti_aff_plan ~__context + (Xapi_ha_vm_failover.compute_no_breach_plan ~__context pool_state + (slave1_anti_aff_vms + |> List.sort (fun (_, a, _) (_, b, _) -> compare a b) + ) + |> fst + ) + + let tests = + `QuickAndAutoDocumented + (anti_aff_plan_test_cases + |> List.map (fun (pool, _spread_evenly_plan, no_breach_plan) -> + (pool, no_breach_plan) + ) + ) +end) + +module Slave1EvacuationPlan = Generic.MakeStateful (struct + module Io = struct + type input_t = pool + + type output_t = (string * string) list + + let string_of_input_t = string_of_pool + + let string_of_output_t = Test_printers.(list (pair string string)) + end + + module State = Test_state.XapiDb + + let load_input __context = setup ~__context + + let extract_output __context _ = + let all_hosts = Db.Host.get_all ~__context in + let slv1 = + Db.Host.get_all ~__context + |> List.find (fun self -> Db.Host.get_name_label ~__context ~self = slave1) + in + let slave1_vms = + Db.Host.get_resident_VMs ~__context ~self:slv1 + |> List.map (fun self -> (self, Db.VM.get_record ~__context ~self)) + |> List.filter (fun (_, record) -> not record.API.vM_is_control_domain) + |> List.map (fun (self, record) -> + (self, Xapi_ha_vm_failover.vm_memory ~__context record) + ) + in + let hosts = + all_hosts + |> List.filter (( <> ) slv1) + |> List.map (fun host -> + (host, Xapi_ha_vm_failover.host_free_memory ~__context ~host) + ) + in + Xapi_ha_vm_failover.compute_anti_aff_evac_plan ~__context + (List.length all_hosts) hosts slave1_vms + |> List.map (fun (vm, host) -> + ( Db.VM.get_name_label ~__context ~self:vm + , Db.Host.get_name_label ~__context ~self:host + ) + ) + + let tests = + `QuickAndAutoDocumented + [ + (* Test 0: Spread evenly plan is taken. *) + ( { + master= {memory_total= gib 200L; name_label= master; vms= []} + ; slaves= + [ + { + memory_total= gib 256L + ; name_label= slave1 + ; vms= + [ + { + basic_vm with + memory= gib 24L + ; name_label= vm4_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 23L + ; name_label= vm3_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 22L + ; name_label= vm2_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 21L + ; name_label= vm1_grp1 + ; groups= [anti_aff_grp1] + } + ] + } + ; {memory_total= gib 60L; name_label= slave2; vms= []} + ] + ; ha_host_failures_to_tolerate= 0L + ; cluster= 0 + } + , (* Assert that spread_evenly_plan is taken. *) + [ + (vm4_grp1, master) + ; (vm3_grp1, slave2) + ; (vm2_grp1, master) + ; (vm1_grp1, slave2) + ] + ) + (* Test 1: No breach plan is taken. *) + ; ( { + master= {memory_total= gib 100L; name_label= master; vms= []} + ; slaves= + [ + { + memory_total= gib 256L + ; name_label= slave1 + ; vms= + [ + {basic_vm with memory= gib 85L; name_label= vm1} + ; {basic_vm with memory= gib 65L; name_label= vm2} + ; { + basic_vm with + memory= gib 30L + ; name_label= vm3_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 20L + ; name_label= vm2_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 10L + ; name_label= vm1_grp1 + ; groups= [anti_aff_grp1] + } + ] + } + ; {memory_total= gib 90L; name_label= slave2; vms= []} + ; {memory_total= gib 70L; name_label= slave3; vms= []} + ] + ; ha_host_failures_to_tolerate= 0L + ; cluster= 0 + } + , (* Assert that no-breach-plan is taken *) + [ + (vm2_grp1, slave2) + ; (vm1_grp1, slave3) + ; (vm3_grp1, slave3) + ; (vm2, slave2) + ; (vm1, master) + ] + ) + (* Test 2: Fallback to binpack plan. *) + ; ( { + master= {memory_total= gib 100L; name_label= master; vms= []} + ; slaves= + [ + { + memory_total= gib 256L + ; name_label= slave1 + ; vms= + [ + {basic_vm with memory= gib 95L; name_label= vm1} + ; {basic_vm with memory= gib 75L; name_label= vm2} + ; { + basic_vm with + memory= gib 30L + ; name_label= vm3_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 20L + ; name_label= vm2_grp1 + ; groups= [anti_aff_grp1] + } + ; { + basic_vm with + memory= gib 10L + ; name_label= vm1_grp1 + ; groups= [anti_aff_grp1] + } + ] + } + ; {memory_total= gib 80L; name_label= slave2; vms= []} + ; {memory_total= gib 70L; name_label= slave3; vms= []} + ] + ; ha_host_failures_to_tolerate= 0L + ; cluster= 0 + } + , (* Assert that binpack-plan is taken *) + [ + (vm1_grp1, slave3) + ; (vm2_grp1, slave3) + ; (vm3_grp1, slave3) + ; (vm2, slave2) + ; (vm1, master) + ] + ) + ] +end) + +let tests = + [ + ("plan_for_n_failures", PlanForNFailures.tests) + ; ( "anti-affinity spread evenly plan" + , Slave1EvacuationVMAntiAffinitySpreadEvenlyPlan.tests + ) + ; ( "anti-affinity no breach plan" + , Slave1EvacuationVMAntiAffinityNoBreachPlan.tests + ) + ; ( "3 phases planning: spread evenly plan, no breach plan, binpacking plan" + , Slave1EvacuationPlan.tests + ) + ] diff --git a/ocaml/xapi/xapi_ha_vm_failover.mli b/ocaml/xapi/xapi_ha_vm_failover.mli index 89a4c3d20e5..20eb3b6b844 100644 --- a/ocaml/xapi/xapi_ha_vm_failover.mli +++ b/ocaml/xapi/xapi_ha_vm_failover.mli @@ -86,3 +86,51 @@ val assert_nfailures_change_preserves_ha_plan : __context:Context.t -> int -> unit val assert_new_vm_preserves_ha_plan : __context:Context.t -> API.ref_VM -> unit + +(* Below exposed only for ease of testing *) + +module VMGrpMap : Map.S with type key = API.ref_VM_group + +module HostKey : sig + type t = API.ref_host +end + +module AntiAffEvacPlanHostPsq : Psq.S with type k = HostKey.t + +val compute_spread_evenly_plan : + __context:Context.t + -> AntiAffEvacPlanHostPsq.t VMGrpMap.t + -> (API.ref_VM * int64 * API.ref_VM_group) list + -> (API.ref_VM * API.ref_host) list + +val compute_no_breach_plan : + __context:Context.t + -> (AntiAffEvacPlanHostPsq.t * int) VMGrpMap.t + -> (API.ref_VM * int64 * API.ref_VM_group) list + -> (API.ref_VM * API.ref_host) list * (API.ref_VM * int64) list + +val compute_anti_aff_evac_plan : + __context:Context.t + -> int + -> (API.ref_host * int64) list + -> (API.ref_VM * int64) list + -> (API.ref_VM * API.ref_host) list + +val host_free_memory : __context:Context.t -> host:API.ref_host -> int64 + +val vm_memory : __context:Context.t -> API.vM_t -> int64 + +val vms_partition : + __context:Context.t + -> (API.ref_VM * 'a) list + -> (API.ref_VM * 'a * API.ref_VM_group) list * (API.ref_VM * 'a) list + +val init_spread_evenly_plan_pool_state : + __context:Context.t + -> ('a * 'b * API.ref_VM_group) list + -> (API.ref_host * int64) list + -> AntiAffEvacPlanHostPsq.t VMGrpMap.t + +val init_no_breach_plan_pool_state : + AntiAffEvacPlanHostPsq.t VMGrpMap.t + -> (AntiAffEvacPlanHostPsq.t * int) VMGrpMap.t From 8a9074f6da15402f45af427631379896066bde6c Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Mon, 3 Jun 2024 08:24:11 +0100 Subject: [PATCH 19/44] CP-48011: Xapi Support anti-affinity feature flag 1. Rename feature flag VM_group to VM_groups. 2. Add feature check in host evacuation Signed-off-by: Bengang Yuan --- ocaml/xapi-types/features.ml | 4 ++-- ocaml/xapi-types/features.mli | 2 +- ocaml/xapi/xapi_ha_vm_failover.ml | 13 ++++++++++--- ocaml/xapi/xapi_vm.ml | 2 +- ocaml/xapi/xapi_vm_group.ml | 2 +- ocaml/xapi/xapi_vm_group_helpers.ml | 6 +++--- ocaml/xapi/xapi_vm_group_helpers.mli | 2 +- ocaml/xapi/xapi_vm_helpers.ml | 2 +- 8 files changed, 20 insertions(+), 13 deletions(-) diff --git a/ocaml/xapi-types/features.ml b/ocaml/xapi-types/features.ml index 97fc9b7f7f5..6e838f32b83 100644 --- a/ocaml/xapi-types/features.ml +++ b/ocaml/xapi-types/features.ml @@ -64,7 +64,7 @@ type feature = | Updates | Internal_repo_access | VTPM - | VM_group + | VM_groups [@@deriving rpc] type orientation = Positive | Negative @@ -133,7 +133,7 @@ let keys_of_features = , ("restrict_internal_repo_access", Negative, "Internal_repo_access") ) ; (VTPM, ("restrict_vtpm", Negative, "VTPM")) - ; (VM_group, ("restrict_vm_group", Negative, "VM_group")) + ; (VM_groups, ("restrict_vm_groups", Negative, "VM_groups")) ] (* A list of features that must be considered "enabled" by `of_assoc_list` diff --git a/ocaml/xapi-types/features.mli b/ocaml/xapi-types/features.mli index bae1496dd78..bcd1ef4ac66 100644 --- a/ocaml/xapi-types/features.mli +++ b/ocaml/xapi-types/features.mli @@ -72,7 +72,7 @@ type feature = | Internal_repo_access (** Enable restriction on repository access to pool members only *) | VTPM (** Support VTPM device required by Win11 guests *) - | VM_group (** Enable use of VM group *) + | VM_groups (** Enable use of VM groups *) val feature_of_rpc : Rpc.t -> feature (** Convert RPC into {!feature}s *) diff --git a/ocaml/xapi/xapi_ha_vm_failover.ml b/ocaml/xapi/xapi_ha_vm_failover.ml index d52fcc1c641..4aa9ee17128 100644 --- a/ocaml/xapi/xapi_ha_vm_failover.ml +++ b/ocaml/xapi/xapi_ha_vm_failover.ml @@ -548,13 +548,20 @@ let compute_anti_aff_evac_plan ~__context total_hosts hosts vms = ) in - match total_hosts with - | h when h < 3 -> + match + (Pool_features.is_enabled ~__context Features.VM_groups, total_hosts) + with + | _, h when h < 3 -> debug "There are less than 2 available hosts to migrate VMs to, \ anti-affinity evacuation plan is not needed." ; binpack_plan ~__context config vms - | _ -> + | false, _ -> + debug + "VM groups feature is disabled, ignore VM anti-affinity during host \ + evacuation" ; + binpack_plan ~__context config vms + | true, _ -> let anti_aff_vms, non_anti_aff_vms = vms |> vms_partition ~__context in let spread_evenly_plan_pool_state = init_spread_evenly_plan_pool_state ~__context anti_aff_vms hosts diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index c08877c54c7..c7f3f6f230e 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1442,7 +1442,7 @@ let set_appliance ~__context ~self ~value = update_allowed_operations ~__context ~self let set_groups ~__context ~self ~value = - Pool_features.assert_enabled ~__context ~f:Features.VM_group ; + Pool_features.assert_enabled ~__context ~f:Features.VM_groups ; if Db.VM.get_is_control_domain ~__context ~self || Db.VM.get_is_a_template ~__context ~self diff --git a/ocaml/xapi/xapi_vm_group.ml b/ocaml/xapi/xapi_vm_group.ml index f04d73e213a..f2a7497737b 100644 --- a/ocaml/xapi/xapi_vm_group.ml +++ b/ocaml/xapi/xapi_vm_group.ml @@ -15,7 +15,7 @@ module D = Debug.Make (struct let name = "xapi_vm_group" end) let create ~__context ~name_label ~name_description ~placement = - Pool_features.assert_enabled ~__context ~f:Features.VM_group ; + Pool_features.assert_enabled ~__context ~f:Features.VM_groups ; let uuid = Uuidx.make () in let ref = Ref.make () in Db.VM_group.create ~__context ~ref ~uuid:(Uuidx.to_string uuid) ~name_label diff --git a/ocaml/xapi/xapi_vm_group_helpers.ml b/ocaml/xapi/xapi_vm_group_helpers.ml index 0a05f41dd96..87fc15b10b5 100644 --- a/ocaml/xapi/xapi_vm_group_helpers.ml +++ b/ocaml/xapi/xapi_vm_group_helpers.ml @@ -139,7 +139,7 @@ let update_vm_anti_affinity_alert_for_group ~__context ~group ~alerts = () let maybe_update_vm_anti_affinity_alert_for_vm ~__context ~vm = - if Pool_features.is_enabled ~__context Features.VM_group then + if Pool_features.is_enabled ~__context Features.VM_groups then try Db.VM.get_groups ~__context ~self:vm |> List.filter (fun g -> @@ -186,7 +186,7 @@ let update_alert ~__context ~groups ~action = with e -> error "%s" (Printexc.to_string e) let update_vm_anti_affinity_alert ~__context ~groups = - if Pool_features.is_enabled ~__context Features.VM_group then + if Pool_features.is_enabled ~__context Features.VM_groups then update_alert ~__context ~groups ~action:update_vm_anti_affinity_alert_for_group else @@ -200,7 +200,7 @@ let maybe_update_alerts_on_feature_change ~__context ~old_restrictions ~new_restrictions = try let is_enabled restrictions = - List.mem Features.VM_group (Features.of_assoc_list restrictions) + List.mem Features.VM_groups (Features.of_assoc_list restrictions) in let groups = Db.VM_group.get_all ~__context in match (is_enabled old_restrictions, is_enabled new_restrictions) with diff --git a/ocaml/xapi/xapi_vm_group_helpers.mli b/ocaml/xapi/xapi_vm_group_helpers.mli index c7ed83e39e1..e2800ee69db 100644 --- a/ocaml/xapi/xapi_vm_group_helpers.mli +++ b/ocaml/xapi/xapi_vm_group_helpers.mli @@ -29,7 +29,7 @@ val maybe_update_alerts_on_feature_change : -> old_restrictions:(string * string) list -> new_restrictions:(string * string) list -> unit -(** Updates the VM anti-affinity alert only when Features.VM_group changes. +(** Updates the VM anti-affinity alert only when Features.VM_groups changes. @param __context The context information. @param old_restrictions The old feature restrictions represented as an association list. diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index cc82f304e07..989686ca2dc 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -913,7 +913,7 @@ let vm_can_run_on_host ~__context ~vm ~snapshot ~do_memory_check host = with _ -> false let vm_has_anti_affinity ~__context ~vm = - if Pool_features.is_enabled ~__context Features.VM_group then + if Pool_features.is_enabled ~__context Features.VM_groups then List.find_opt (fun g -> Db.VM_group.get_placement ~__context ~self:g = `anti_affinity) (Db.VM.get_groups ~__context ~self:vm) From de02e53c9461e205ee40ccd4ae50434cbede0b41 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Tue, 25 Jun 2024 16:16:46 +0100 Subject: [PATCH 20/44] CP-49953: Remove parse_uri, switch to using Uri module instead Signed-off-by: Andrii Sultanov --- ocaml/libs/http-lib/http.ml | 45 --------------------------------- ocaml/libs/http-lib/http.mli | 6 ----- ocaml/libs/http-lib/http_svr.ml | 11 +++++++- 3 files changed, 10 insertions(+), 52 deletions(-) diff --git a/ocaml/libs/http-lib/http.ml b/ocaml/libs/http-lib/http.ml index be2d4c2c0c5..6b92a014512 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -208,15 +208,6 @@ let parse_keyvalpairs xs = ) kvpairs -let parse_uri x = - match Astring.String.cuts ~sep:"?" x with - | [uri] -> - (uri, []) - | [uri; params] -> - (uri, parse_keyvalpairs params) - | _ -> - raise Http_parse_failure - type authorization = Basic of string * string | UnknownAuth of string [@@deriving rpc] @@ -629,42 +620,6 @@ module Request = struct let get_version x = x.version - let of_request_line x = - match Astring.String.fields ~empty:false x with - | [m; uri; version] -> ( - (* Request-Line = Method SP Request-URI SP HTTP-Version CRLF *) - let uri, query = parse_uri uri in - (* strip the "HTTP/" prefix from the version string *) - match Astring.String.cut ~sep:"/" version with - | Some (_, version) -> - { - m= method_t_of_string m - ; frame= false - ; uri - ; query - ; content_length= None - ; transfer_encoding= None - ; accept= None - ; version - ; cookie= [] - ; auth= None - ; task= None - ; subtask_of= None - ; content_type= None - ; host= None - ; user_agent= None - ; close= false - ; additional_headers= [] - ; body= None - ; traceparent= None - } - | None -> - error "Failed to parse: %s" x ; - raise Http_parse_failure - ) - | _ -> - raise Http_parse_failure - let to_string x = let kvpairs x = String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) x) diff --git a/ocaml/libs/http-lib/http.mli b/ocaml/libs/http-lib/http.mli index 84326e38012..0f561391de7 100644 --- a/ocaml/libs/http-lib/http.mli +++ b/ocaml/libs/http-lib/http.mli @@ -119,10 +119,6 @@ module Request : sig val get_version : t -> string (** [get_version t] returns the HTTP protocol version *) - val of_request_line : string -> t - (** [of_request_line l] parses [l] of the form "METHOD HTTP/VERSION" and - returns the corresponding [t] *) - val to_string : t -> string (** [to_string t] returns a short string summarising [t] *) @@ -176,8 +172,6 @@ end val authorization_of_string : string -> authorization -val parse_uri : string -> string * (string * string) list - val http_403_forbidden : ?version:string -> unit -> string list val http_200_ok : ?version:string -> ?keep_alive:bool -> unit -> string list diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index c824277e5be..2950bb3f79b 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -359,6 +359,12 @@ let request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length bio proxy |> Option.fold ~none:[] ~some:(fun p -> [("STUNNEL_PROXY", p)]) in let open Http.Request in + (* Below transformation only keeps one value per key, whereas + a fully compliant implementation following Uri's interface + would operate on list of values for each key instead *) + let kvlist_flatten ls = + List.map (function k, v :: _ -> (k, v) | k, [] -> (k, "")) ls + in let request = Astring.String.cuts ~sep:"\n" headers |> List.fold_left @@ -367,7 +373,10 @@ let request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length bio match Astring.String.fields ~empty:false header with | [meth; uri; version] -> (* Request-Line = Method SP Request-URI SP HTTP-Version CRLF *) - let uri, query = Http.parse_uri uri in + let uri_t = Uri.of_string uri in + if uri_t = Uri.empty then raise Http_parse_failure ; + let uri = Uri.path uri_t in + let query = Uri.query uri_t |> kvlist_flatten in let m = Http.method_t_of_string meth in let version = let x = String.trim version in From 5e51f8ef2582e6a5837b35ca5f2157a8e7edf86d Mon Sep 17 00:00:00 2001 From: Steven Woods Date: Tue, 25 Jun 2024 11:22:24 +0100 Subject: [PATCH 21/44] CP-49116: Replace fingerprint in certificate DB with sha256 and sha1 equivalents. This allows support to be added to external_certificate_thumbprint_of_master for Sha1 fingerprints. Signed-off-by: Steven Woods --- ocaml/idl/datamodel_certificate.ml | 10 +++++- ocaml/idl/datamodel_common.ml | 2 +- ocaml/idl/schematest.ml | 2 +- ocaml/xapi-cli-server/records.ml | 6 ++++ ocaml/xapi/api_server.ml | 26 ++++++++------- ocaml/xapi/certificates.ml | 10 ++++-- ocaml/xapi/certificates_sync.ml | 4 ++- ocaml/xapi/helpers.ml | 53 ++++++++++++++++-------------- ocaml/xapi/xapi_globs.ml | 4 ++- ocaml/xapi/xapi_pool.ml | 4 ++- 10 files changed, 77 insertions(+), 44 deletions(-) diff --git a/ocaml/idl/datamodel_certificate.ml b/ocaml/idl/datamodel_certificate.ml index ac77887b9f0..409d35e8233 100644 --- a/ocaml/idl/datamodel_certificate.ml +++ b/ocaml/idl/datamodel_certificate.ml @@ -64,8 +64,16 @@ let t = ; field ~qualifier:StaticRO ~lifecycle ~ty:DateTime "not_after" ~default_value:(Some (VDateTime Date.never)) "Date before which the certificate is valid" - ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint" + ; field ~qualifier:StaticRO + ~lifecycle: + [(Published, rel_stockholm, ""); (Deprecated, "24.19.0", "")] + ~ty:String "fingerprint" ~default_value:(Some (VString "")) + "Use fingerprint_sha256 instead" + ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint_sha256" ~default_value:(Some (VString "")) "The certificate's SHA256 fingerprint / hash" + ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint_sha1" + ~default_value:(Some (VString "")) + "The certificate's SHA1 fingerprint / hash" ] ~messages:[] () diff --git a/ocaml/idl/datamodel_common.ml b/ocaml/idl/datamodel_common.ml index 64e3481dc21..962ad7bdd39 100644 --- a/ocaml/idl/datamodel_common.ml +++ b/ocaml/idl/datamodel_common.ml @@ -10,7 +10,7 @@ open Datamodel_roles to leave a gap for potential hotfixes needing to increment the schema version.*) let schema_major_vsn = 5 -let schema_minor_vsn = 778 +let schema_minor_vsn = 779 (* Historical schema versions just in case this is useful later *) let rio_schema_major_vsn = 5 diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index 7bdc6f21276..8ec11645226 100644 --- a/ocaml/idl/schematest.ml +++ b/ocaml/idl/schematest.ml @@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex (* BEWARE: if this changes, check that schema has been bumped accordingly in ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *) -let last_known_schema_hash = "6566a4091ecb3200649185730e4f185d" +let last_known_schema_hash = "e34cd0d32cdcec7805c2d3ed4e4a0c25" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/xapi-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index 92c27c6917c..2b3a562d4f5 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -5237,6 +5237,12 @@ let certificate_record rpc session_id certificate = ; make_field ~name:"fingerprint" ~get:(fun () -> (x ()).API.certificate_fingerprint) () + ; make_field ~name:"fingerprint_sha256" + ~get:(fun () -> (x ()).API.certificate_fingerprint_sha256) + () + ; make_field ~name:"fingerprint_sha1" + ~get:(fun () -> (x ()).API.certificate_fingerprint_sha1) + () ] } diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index 711655148b3..9194a31b122 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -250,24 +250,28 @@ let is_host_is_slave_error (response : Rpc.response) = false let create_thumbprint_header req response = - let include_thumbprint = + let hash_type_opt = match List.assoc_opt !Xapi_globs.cert_thumbprint_header_request req.Http.Request.additional_headers with - | Some x when x = !Xapi_globs.cert_thumbprint_header_value -> - true + | Some x when x = !Xapi_globs.cert_thumbprint_header_value_sha256 -> + Some `Sha256 + | Some x when x = !Xapi_globs.cert_thumbprint_header_value_sha1 -> + Some `Sha1 | _ -> - false + None in - if include_thumbprint && is_host_is_slave_error response then - Helpers.external_certificate_thumbprint_of_master () - |> Option.fold ~none:[] ~some:(fun x -> - [(!Xapi_globs.cert_thumbprint_header_response, x)] - ) - else - [] + Option.bind hash_type_opt (fun hash_type -> + if is_host_is_slave_error response then + Helpers.external_certificate_thumbprint_of_master ~hash_type + else + None + ) + |> Option.fold ~none:[] ~some:(fun x -> + [(!Xapi_globs.cert_thumbprint_header_response, x)] + ) module Unixext = Xapi_stdext_unix.Unixext diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 0204b7b064a..4f6747762ea 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -66,7 +66,7 @@ let update_ca_bundle () = Helpers.update_ca_bundle () let to_string = function CA_Certificate -> "CA certificate" | CRL -> "CRL" (** {pp_hash hash} outputs the hexadecimal representation of the {hash} - adding a semicolon between every octet, in uppercase. + adding a colon between every octet, in uppercase. *) let pp_hash hash = let hex = Hex.(show @@ of_cstruct hash) in @@ -218,13 +218,17 @@ end = struct let not_before, not_after = dates_of_ptimes (X509.Certificate.validity certificate) in - let fingerprint = + let fingerprint_sha256 = X509.Certificate.fingerprint `SHA256 certificate |> pp_hash in + let fingerprint_sha1 = + X509.Certificate.fingerprint `SHA1 certificate |> pp_hash + in let uuid = Uuidx.(to_string (make ())) in let ref' = Ref.make () in Db.Certificate.create ~__context ~ref:ref' ~uuid ~host ~not_before - ~not_after ~fingerprint ~name ~_type ; + ~not_after ~fingerprint:fingerprint_sha256 ~fingerprint_sha256 + ~fingerprint_sha1 ~name ~_type ; debug "added cert %s under uuid=%s ref=%s" name uuid (Ref.string_of ref') ; post_action () ; ref' diff --git a/ocaml/xapi/certificates_sync.ml b/ocaml/xapi/certificates_sync.ml index e578d10e084..735b1a9c936 100644 --- a/ocaml/xapi/certificates_sync.ml +++ b/ocaml/xapi/certificates_sync.ml @@ -32,7 +32,9 @@ let install ~__context ~host:_ ~type' cert = (** determine if the database is up to date by comparing the fingerprint of xapi-ssl.pem with the entry in the database *) let is_unchanged ~__context cert_ref cert = - let ref_hash = Db.Certificate.get_fingerprint ~__context ~self:cert_ref in + let ref_hash = + Db.Certificate.get_fingerprint_sha256 ~__context ~self:cert_ref + in let cert_hash = X509.Certificate.fingerprint `SHA256 cert |> Certificates.pp_hash in diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index ba58ddd7b92..69e2ba3ce24 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -2041,30 +2041,35 @@ let update_ca_bundle = ) ) -let external_certificate_thumbprint_of_master ?(hash_type = `Sha256) () = - match hash_type with - | `Sha256 -> - Server_helpers.exec_with_new_task - "Get master's external certificate thumbprint" (fun __context -> - let master_ref = get_master ~__context in - let certs = - Db.Certificate.get_records_where ~__context - ~expr: - (And - ( Eq (Field "host", Literal (Ref.string_of master_ref)) - , Eq (Field "type", Literal "host") - ) - ) - in - match certs with - | [] -> - debug "Failed to fetch master's external certificate" ; - None - | (_, cert_record) :: _ -> - Some cert_record.certificate_fingerprint - ) - | _ -> - None +let external_certificate_thumbprint_of_master ~hash_type = + if List.mem hash_type [`Sha256; `Sha1] then + Server_helpers.exec_with_new_task + "Get master's external certificate thumbprint" (fun __context -> + let master_ref = get_master ~__context in + let certs = + Db.Certificate.get_records_where ~__context + ~expr: + (And + ( Eq (Field "host", Literal (Ref.string_of master_ref)) + , Eq (Field "type", Literal "host") + ) + ) + in + match certs with + | [] -> + debug "%s: Failed to fetch master's external certificate" + __FUNCTION__ ; + None + | (_, cert_record) :: _ -> ( + match hash_type with + | `Sha256 -> + Some cert_record.certificate_fingerprint_sha256 + | `Sha1 -> + Some cert_record.certificate_fingerprint_sha1 + ) + ) + else + None let unit_test ~__context : bool = Pool_role.is_unit_test () diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index c8bf2adaa8b..7dbfb8da582 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -1020,7 +1020,9 @@ let max_observer_file_size = ref (1 lsl 20) let cert_thumbprint_header_request = ref "x-xenapi-request-host-certificate-thumbprint" -let cert_thumbprint_header_value = ref "sha-256:master" +let cert_thumbprint_header_value_sha256 = ref "sha-256:master" + +let cert_thumbprint_header_value_sha1 = ref "sha-1:master" let cert_thumbprint_header_response = ref "x-xenapi-response-host-certificate-thumbprint" diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index 2d3a13304c7..7013706ead1 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -775,7 +775,9 @@ let pre_join_checks ~__context ~rpc ~session_id ~force = list |> List.to_seq |> Seq.map (fun (_, record) -> - (record.API.certificate_name, record.API.certificate_fingerprint) + ( record.API.certificate_name + , record.API.certificate_fingerprint_sha256 + ) ) |> CertMap.of_seq in From 59755626888b8c3bc64b6b873dee196913348944 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Tue, 18 Jun 2024 16:43:14 +0100 Subject: [PATCH 22/44] CA-392887: set_tls_config immediately after enabling clustering Previously xapi calls `set_tls_config` regardless of whether a host has joined or enabled, which will restart the remote server of xapi-clusterd. In the meantime, another xapi-clusterd might also be joining, which causes `distribute_state` to be called while the remote server is restarting. Now remove the `set_tls_config`, this is because `join_internal` already creates a tls_config and passes it to xapi-clusterd, but xapi-clusterd does not store that tls_config in its db, it just starts the http server with that tls config. Modifying xapi-clusterd to store that config will be done in a separate PR. Moreover, `cluster_host.enable` also calls `set_tls_config`, which means there is no need to call `set_tls_config` if the cluster host is joined but not enabled. Also move the observer and watcher creation into the not joined case, since cluster_host.enable already calls them and there is no need to call them if the host is not enabled. This does not, however, solve the whole problem. For that, we need to make sure that `distribute_state` and `set_tls_config` cannot happen at the same time. More generally, any remote calls cannot happen while `tls_config` is running. Hence we need them to hold the same lock. This will be done in xapi-clusterd. Signed-off-by: Vincent Liu --- ocaml/xapi/xapi_cluster_host.ml | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/ocaml/xapi/xapi_cluster_host.ml b/ocaml/xapi/xapi_cluster_host.ml index de14b266a96..782d5a240f5 100644 --- a/ocaml/xapi/xapi_cluster_host.ml +++ b/ocaml/xapi/xapi_cluster_host.ml @@ -230,9 +230,12 @@ let resync_host ~__context ~host = ~msg:Api_messages.cluster_host_enable_failed ~cls:`Host ~obj_uuid ~body ~api_func:(fun rpc session_id -> (* If we have just joined, enable will prevent concurrent clustering ops *) - if not (Db.Cluster_host.get_joined ~__context ~self) then - join_internal ~__context ~self - else if Db.Cluster_host.get_enabled ~__context ~self then ( + if not (Db.Cluster_host.get_joined ~__context ~self) then ( + join_internal ~__context ~self ; + create_cluster_watcher_on_master ~__context ~host ; + Xapi_observer.initialise_observer ~__context + Xapi_observer_components.Xapi_clusterd + ) else if Db.Cluster_host.get_enabled ~__context ~self then ( (* [enable] unconditionally invokes low-level enable operations and is idempotent. RPU reformats partition, losing service status, never re-enables clusterd *) debug "Cluster_host %s is enabled, starting up xapi-clusterd" @@ -241,13 +244,7 @@ let resync_host ~__context ~host = maybe_switch_cluster_stack_version ~__context ~self ~cluster_stack ; (* Note that join_internal and enable both use the clustering lock *) Client.Client.Cluster_host.enable ~rpc ~session_id ~self - ) ; - (* create the watcher here so that the watcher exists after toolstack restart *) - create_cluster_watcher_on_master ~__context ~host ; - Xapi_observer.initialise_observer ~__context - Xapi_observer_components.Xapi_clusterd ; - let verify = Stunnel_client.get_verify_by_default () in - set_tls_config ~__context ~self ~verify + ) ) (* API call split into separate functions to create in db and enable in client layer *) From ee8e80032f17c97e0f2aa4952a531b81a5c0ce94 Mon Sep 17 00:00:00 2001 From: Bernhard Kaindl Date: Tue, 2 Jul 2024 12:09:50 +0200 Subject: [PATCH 23/44] CI: Update endcover step to v2 to fix CI (#5763) Signed-off-by: Bernhard Kaindl --- .github/workflows/other.yml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.github/workflows/other.yml b/.github/workflows/other.yml index 9974a15fcd8..57d4c1d2207 100644 --- a/.github/workflows/other.yml +++ b/.github/workflows/other.yml @@ -115,13 +115,15 @@ jobs: # To view the Coveralls results of the PR, click on the "Details" link to the right # of the Coveralls Logo in the Checks section of the PR. finish-parallel-coveralls-upload: + name: Finish coverage upload needs: python-test # run after the python-test has completed uploading coverages runs-on: ubuntu-latest steps: - name: Finish the parallel coverage upload to Coveralls - uses: coverallsapp/github-action@v1 + uses: coverallsapp/github-action@v2 with: parallel-finished: true + continue-on-error: true # Do not fail CI if this step fails deprecation-test: name: Deprecation tests From 3c146076b25056b47d8f543aee05014be24a16ca Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Tue, 2 Jul 2024 15:09:23 +0100 Subject: [PATCH 24/44] CA-386173: Update the message of WLB authentication issue Signed-off-by: Bengang Yuan --- ocaml/idl/datamodel_errors.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 81dc1e10ed2..71f08f8bd90 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -916,7 +916,10 @@ let _ = error Api_errors.wlb_timeout ["configured_timeout"] ~doc:"The communication with the WLB server timed out." () ; error Api_errors.wlb_authentication_failed [] - ~doc:"WLB rejected our configured authentication details." () ; + ~doc: + "Failed to authenticate with the WLB server, the provided credentials \ + are invalid." + () ; error Api_errors.wlb_malformed_request [] ~doc:"WLB rejected the server's request as malformed." () ; error Api_errors.wlb_malformed_response From 753a65560dfebfb2223e5313409b14787b83e0d5 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 3 Jul 2024 10:14:28 +0100 Subject: [PATCH 25/44] Revert "CP-49953: Remove parse_uri, switch to using Uri module instead" This reverts commit 31eeb93f497e5229502a04c4867cf7f0d46db756. --- ocaml/libs/http-lib/http.ml | 45 +++++++++++++++++++++++++++++++++ ocaml/libs/http-lib/http.mli | 6 +++++ ocaml/libs/http-lib/http_svr.ml | 11 +------- 3 files changed, 52 insertions(+), 10 deletions(-) diff --git a/ocaml/libs/http-lib/http.ml b/ocaml/libs/http-lib/http.ml index 6b92a014512..be2d4c2c0c5 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -208,6 +208,15 @@ let parse_keyvalpairs xs = ) kvpairs +let parse_uri x = + match Astring.String.cuts ~sep:"?" x with + | [uri] -> + (uri, []) + | [uri; params] -> + (uri, parse_keyvalpairs params) + | _ -> + raise Http_parse_failure + type authorization = Basic of string * string | UnknownAuth of string [@@deriving rpc] @@ -620,6 +629,42 @@ module Request = struct let get_version x = x.version + let of_request_line x = + match Astring.String.fields ~empty:false x with + | [m; uri; version] -> ( + (* Request-Line = Method SP Request-URI SP HTTP-Version CRLF *) + let uri, query = parse_uri uri in + (* strip the "HTTP/" prefix from the version string *) + match Astring.String.cut ~sep:"/" version with + | Some (_, version) -> + { + m= method_t_of_string m + ; frame= false + ; uri + ; query + ; content_length= None + ; transfer_encoding= None + ; accept= None + ; version + ; cookie= [] + ; auth= None + ; task= None + ; subtask_of= None + ; content_type= None + ; host= None + ; user_agent= None + ; close= false + ; additional_headers= [] + ; body= None + ; traceparent= None + } + | None -> + error "Failed to parse: %s" x ; + raise Http_parse_failure + ) + | _ -> + raise Http_parse_failure + let to_string x = let kvpairs x = String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) x) diff --git a/ocaml/libs/http-lib/http.mli b/ocaml/libs/http-lib/http.mli index 0f561391de7..84326e38012 100644 --- a/ocaml/libs/http-lib/http.mli +++ b/ocaml/libs/http-lib/http.mli @@ -119,6 +119,10 @@ module Request : sig val get_version : t -> string (** [get_version t] returns the HTTP protocol version *) + val of_request_line : string -> t + (** [of_request_line l] parses [l] of the form "METHOD HTTP/VERSION" and + returns the corresponding [t] *) + val to_string : t -> string (** [to_string t] returns a short string summarising [t] *) @@ -172,6 +176,8 @@ end val authorization_of_string : string -> authorization +val parse_uri : string -> string * (string * string) list + val http_403_forbidden : ?version:string -> unit -> string list val http_200_ok : ?version:string -> ?keep_alive:bool -> unit -> string list diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index 2950bb3f79b..c824277e5be 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -359,12 +359,6 @@ let request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length bio proxy |> Option.fold ~none:[] ~some:(fun p -> [("STUNNEL_PROXY", p)]) in let open Http.Request in - (* Below transformation only keeps one value per key, whereas - a fully compliant implementation following Uri's interface - would operate on list of values for each key instead *) - let kvlist_flatten ls = - List.map (function k, v :: _ -> (k, v) | k, [] -> (k, "")) ls - in let request = Astring.String.cuts ~sep:"\n" headers |> List.fold_left @@ -373,10 +367,7 @@ let request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length bio match Astring.String.fields ~empty:false header with | [meth; uri; version] -> (* Request-Line = Method SP Request-URI SP HTTP-Version CRLF *) - let uri_t = Uri.of_string uri in - if uri_t = Uri.empty then raise Http_parse_failure ; - let uri = Uri.path uri_t in - let query = Uri.query uri_t |> kvlist_flatten in + let uri, query = Http.parse_uri uri in let m = Http.method_t_of_string meth in let version = let x = String.trim version in From e53ce67ad6fe226008f1877bd346461b372a110d Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 3 Jul 2024 13:06:38 +0100 Subject: [PATCH 26/44] Fix a bug noticed by a quicktest run Introduces percent-decoding back - in the past we used to do urlencode in parse_uri instead. Signed-off-by: Andrii Sultanov --- ocaml/libs/http-lib/http_svr.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index 2950bb3f79b..c27f59a7949 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -375,7 +375,7 @@ let request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length bio (* Request-Line = Method SP Request-URI SP HTTP-Version CRLF *) let uri_t = Uri.of_string uri in if uri_t = Uri.empty then raise Http_parse_failure ; - let uri = Uri.path uri_t in + let uri = Uri.path uri_t |> Uri.pct_decode in let query = Uri.query uri_t |> kvlist_flatten in let m = Http.method_t_of_string meth in let version = From 845ffdd4cd1ca14d66c9dd8eefd2ee5bd38d9553 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Fri, 28 Jun 2024 16:09:21 +0100 Subject: [PATCH 27/44] Eliminate unnecessary usage of List.length to check for empty lists Signed-off-by: Andrii Sultanov --- ocaml/idl/dtd_backend.ml | 4 +- ocaml/libs/ezxenstore/core/watch.ml | 2 +- ocaml/libs/http-lib/buf_io.ml | 2 +- ocaml/libs/xml-light2/xml.ml | 2 +- .../powershell/gen_powershell_binding.ml | 12 +- ocaml/tests/common/alcotest_comparators.ml | 4 +- ocaml/xapi-cli-server/cli_frontend.ml | 2 +- ocaml/xapi-cli-server/cli_operations.ml | 123 +++++++++--------- ocaml/xapi-cli-server/cli_printer.ml | 3 +- ocaml/xapi-idl/lib_test/updates_test.ml | 8 +- ocaml/xapi/create_misc.ml | 4 +- ocaml/xapi/create_storage.ml | 2 +- ocaml/xapi/helpers.ml | 2 +- ocaml/xapi/map_check.ml | 2 +- ocaml/xapi/message_forwarding.ml | 2 +- ocaml/xapi/workload_balancing.ml | 2 +- ocaml/xapi/xapi_bond.ml | 2 +- ocaml/xapi/xapi_ha.ml | 6 +- ocaml/xapi/xapi_host.ml | 4 +- ocaml/xapi/xapi_network.ml | 2 +- ocaml/xapi/xapi_pbd.ml | 2 +- ocaml/xapi/xapi_pgpu_helpers.ml | 2 +- ocaml/xapi/xapi_pif.ml | 2 +- ocaml/xapi/xapi_pool.ml | 16 +-- ocaml/xapi/xapi_pool_update.ml | 2 +- ocaml/xapi/xapi_pvs_proxy.ml | 2 +- ocaml/xapi/xapi_role.ml | 4 +- ocaml/xapi/xapi_session.ml | 6 +- ocaml/xapi/xapi_sr.ml | 2 +- ocaml/xapi/xapi_sr_operations.ml | 6 +- ocaml/xapi/xapi_vdi.ml | 2 +- ocaml/xapi/xapi_vm_appliance_lifecycle.ml | 4 +- ocaml/xapi/xapi_vm_helpers.ml | 2 +- ocaml/xapi/xapi_vmss.ml | 7 +- ocaml/xapi/xapi_xenops.ml | 4 +- ocaml/xe-cli/newcli.ml | 2 +- .../async_examples/event_test.ml | 2 +- ocaml/xenopsd/test/test.ml | 2 +- ocaml/xenopsd/xc/domain.ml | 2 +- ocaml/xenopsd/xc/hotplug.ml | 9 +- quality-gate.sh | 23 +++- 41 files changed, 159 insertions(+), 134 deletions(-) diff --git a/ocaml/idl/dtd_backend.ml b/ocaml/idl/dtd_backend.ml index e94cf4a9178..da448043c39 100644 --- a/ocaml/idl/dtd_backend.ml +++ b/ocaml/idl/dtd_backend.ml @@ -41,7 +41,7 @@ let is_element = function Element (_, _, _) -> true | _ -> false let string_of_attribute = function | Attribute (n, options, default) -> let opt_string = - if List.length options = 0 then + if options = [] then "CDATA" else "(" ^ String.concat " | " options ^ ")" @@ -59,7 +59,7 @@ let string_of_attribute = function sprintf "%s %s %s" n opt_string def_string let strings_of_attributes parent atts = - if List.length atts > 0 then + if atts <> [] then let prefix = sprintf ""] diff --git a/ocaml/libs/ezxenstore/core/watch.ml b/ocaml/libs/ezxenstore/core/watch.ml index 93cd19af3d1..35f3aee0b5e 100644 --- a/ocaml/libs/ezxenstore/core/watch.ml +++ b/ocaml/libs/ezxenstore/core/watch.ml @@ -51,7 +51,7 @@ let wait_for ~xs ?(timeout = 300.) (x : 'a t) = Thread.create (fun () -> let r, _, _ = Unix.select [p1] [] [] timeout in - if List.length r > 0 then + if r <> [] then () else try Xs_client_unix.Task.cancel task with _ -> () diff --git a/ocaml/libs/http-lib/buf_io.ml b/ocaml/libs/http-lib/buf_io.ml index efeda873c5f..6a6397a614c 100644 --- a/ocaml/libs/http-lib/buf_io.ml +++ b/ocaml/libs/http-lib/buf_io.ml @@ -80,7 +80,7 @@ let fill_buf ~buffered ic timeout = let buf_size = Bytes.length ic.buf in let fill_no_exc timeout len = let l, _, _ = Unix.select [ic.fd] [] [] timeout in - if List.length l <> 0 then ( + if l <> [] then ( let n = Unix.read ic.fd ic.buf ic.max len in ic.max <- n + ic.max ; if n = 0 && len <> 0 then raise Eof ; diff --git a/ocaml/libs/xml-light2/xml.ml b/ocaml/libs/xml-light2/xml.ml index 78811ae55d2..9b58f2f6cf0 100644 --- a/ocaml/libs/xml-light2/xml.ml +++ b/ocaml/libs/xml-light2/xml.ml @@ -121,7 +121,7 @@ let esc_pcdata data = let str_of_attrs attrs = let fmt s = Printf.sprintf s in - if List.length attrs > 0 then + if attrs <> [] then " " ^ String.concat " " (List.map (fun (k, v) -> fmt "%s=\"%s\"" k (esc_pcdata v)) attrs) diff --git a/ocaml/sdk-gen/powershell/gen_powershell_binding.ml b/ocaml/sdk-gen/powershell/gen_powershell_binding.ml index b455d010486..0e8c6566dc7 100644 --- a/ocaml/sdk-gen/powershell/gen_powershell_binding.ml +++ b/ocaml/sdk-gen/powershell/gen_powershell_binding.ml @@ -644,14 +644,14 @@ and gen_destructor obj classname messages = Licence.bsd_two_clause (ocaml_class_to_csharp_class classname) (qualified_class_name classname) - ( if List.length asyncMessages > 0 then + ( if asyncMessages <> [] then "\n [OutputType(typeof(XenAPI.Task))]" else "" ) (ocaml_class_to_csharp_class classname) (print_xenobject_params obj classname true true true) - ( if List.length asyncMessages > 0 then + ( if asyncMessages <> [] then sprintf "\n\ \ protected override bool GenerateAsyncParam\n\ @@ -725,7 +725,7 @@ and gen_remover obj classname messages = Licence.bsd_two_clause (ocaml_class_to_csharp_class classname) (qualified_class_name classname) - ( if List.length asyncMessages > 0 then + ( if asyncMessages <> [] then "\n [OutputType(typeof(XenAPI.Task))]" else "" @@ -790,7 +790,7 @@ and gen_setter obj classname messages = Licence.bsd_two_clause (ocaml_class_to_csharp_class classname) (qualified_class_name classname) - ( if List.length asyncMessages > 0 then + ( if asyncMessages <> [] then "\n [OutputType(typeof(XenAPI.Task))]" else "" @@ -855,7 +855,7 @@ and gen_adder obj classname messages = Licence.bsd_two_clause (ocaml_class_to_csharp_class classname) (qualified_class_name classname) - ( if List.length asyncMessages > 0 then + ( if asyncMessages <> [] then "\n [OutputType(typeof(XenAPI.Task))]" else "" @@ -1060,7 +1060,7 @@ and is_message_with_dynamic_params classname message = let nonClassParams = List.filter (fun x -> not (is_class x classname)) message.msg_params in - if List.length nonClassParams > 0 || message.msg_async then + if nonClassParams <> [] || message.msg_async then true else false diff --git a/ocaml/tests/common/alcotest_comparators.ml b/ocaml/tests/common/alcotest_comparators.ml index 21f596875ea..5b4704c3177 100644 --- a/ocaml/tests/common/alcotest_comparators.ml +++ b/ocaml/tests/common/alcotest_comparators.ml @@ -59,6 +59,6 @@ let vdi_operations_set : API.vdi_operations_set Alcotest.testable = ) (fun o1 o2 -> List.length (intersect o1 o2) = List.length o1 - && List.length (set_difference o1 o2) = 0 - && List.length (set_difference o2 o1) = 0 + && set_difference o1 o2 = [] + && set_difference o2 o1 = [] ) diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index 13c695da5db..a3e2eaf5b5a 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -3918,7 +3918,7 @@ let rio_help printer minimal cmd = ) cmd.params in - if List.length cmds > 0 then + if cmds <> [] then List.iter docmd (List.map fst cmds) else let cmds = diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 54eace11b69..cdd29e778be 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -229,7 +229,7 @@ let get_hosts_by_name_or_id rpc session_id name = let get_host_by_name_or_id rpc session_id name = let hosts = get_hosts_by_name_or_id rpc session_id name in - if List.length hosts = 0 then failwith ("Host " ^ name ^ " not found") ; + if hosts = [] then failwith ("Host " ^ name ^ " not found") ; List.nth hosts 0 let get_host_from_session rpc session_id = @@ -862,7 +862,7 @@ let make_param_funs getallrecs getbyuuid record class_name def_filters ] in let ops = - if List.length settable > 0 then + if settable <> [] then ( cli_name "param-set" , ["uuid"] , settable @@ -877,7 +877,7 @@ let make_param_funs getallrecs getbyuuid record class_name def_filters ops in let ops = - if List.length addable > 0 then + if addable <> [] then ops @ [ ( cli_name "param-add" @@ -902,7 +902,7 @@ let make_param_funs getallrecs getbyuuid record class_name def_filters ops in let ops = - if List.length clearable > 0 then + if clearable <> [] then ops @ [ ( cli_name "param-clear" @@ -2928,13 +2928,7 @@ let event_wait_gen rpc session_id classname record_matches = (List.map (fun r -> (r.name, fun () -> safe_get_field r))) current_tbls in - debug "Got %d records" (List.length all_recs) ; - (* true if anything matches now *) - let find_any_match recs = - let ls = List.map record_matches recs in - List.length (List.filter (fun x -> x) ls) > 0 - in - find_any_match all_recs + List.exists record_matches all_recs in finally (fun () -> @@ -3305,9 +3299,9 @@ let do_host_op rpc session_id op params ?(multiple = true) ignore_params = failwith "No matching hosts found" | 1 -> [op 1 (List.hd hosts)] - | _ -> + | len -> if multiple && get_bool_param params "multiple" then - do_multiple (op (List.length hosts)) hosts + do_multiple (op len) hosts else failwith ( if not multiple then @@ -3917,11 +3911,13 @@ let vm_install_real printer rpc session_id template name description params = failwith "SR specified via sr-uuid doesn't have the name specified via \ sr-name-label" - | None -> - if List.length sr_list > 1 then + | None -> ( + match sr_list with + | [x] -> + Some x + | _ -> failwith "Multiple SRs with that name-label found" - else - Some (List.hd sr_list) + ) ) else sr_ref @@ -4058,12 +4054,12 @@ let vm_install printer rpc session_id params = List.fold_left filter_records_on_fields all_recs (("name-label", name) :: filter_params) in - match List.length templates with - | 0 -> + match templates with + | [] -> failwith "No templates matched" - | 1 -> - (List.hd templates).getref () - | _ -> + | [x] -> + x.getref () + | _ :: _ :: _ -> failwith "More than one matching template found" in if @@ -4114,7 +4110,7 @@ let console fd _printer rpc session_id params = | [] -> marshal fd (Command (PrintStderr "No VM found\n")) ; raise (ExitWithError 1) - | _ :: _ -> + | _ :: _ :: _ -> marshal fd (Command (PrintStderr @@ -4153,9 +4149,10 @@ let vm_uninstall_common fd _printer rpc session_id params vms = (* add extra text if the VDI is being shared *) let r = Client.VDI.get_record ~rpc ~session_id ~self:vdi in Printf.sprintf "VDI: %s (%s) %s" r.API.vDI_uuid r.API.vDI_name_label - ( if List.length r.API.vDI_VBDs <= 1 then + ( match r.API.vDI_VBDs with + | [] | [_] -> "" - else + | _ :: _ :: _ -> " ** WARNING: disk is shared by other VMs" ) in @@ -4477,18 +4474,15 @@ let vm_retrieve_wlb_recommendations printer rpc session_id params = in try let vms = select_vms rpc session_id params [] in - match List.length vms with - | 0 -> + match vms with + | [] -> failwith "No matching VMs found" - | 1 -> + | [x] -> printer (Cli_printer.PTable - [ - ("Host(Uuid)", "Stars, RecID, ZeroScoreReason") - :: table (List.hd vms) - ] + [("Host(Uuid)", "Stars, RecID, ZeroScoreReason") :: table x] ) - | _ -> + | _ :: _ :: _ -> failwith "Multiple VMs found. Operation can only be performed on one VM at a \ time" @@ -4628,7 +4622,7 @@ let vm_migrate printer rpc session_id params = ) pifs in - if List.length management_pifs = 0 then + if management_pifs = [] then failwith (Printf.sprintf "Could not find management PIF on host %s" host_record.API.host_uuid @@ -5026,7 +5020,7 @@ let vm_disk_remove printer rpc session_id params = (fun x -> device = Client.VBD.get_userdevice ~rpc ~session_id ~self:x) vm_record.API.vM_VBDs in - if List.length vbd_to_remove < 1 then + if vbd_to_remove = [] then failwith "Disk not found" else let vbd = List.nth vbd_to_remove 0 in @@ -5052,7 +5046,7 @@ let vm_cd_remove printer rpc session_id params = ) vm_record.API.vM_VBDs in - if List.length vbd_to_remove < 1 then + if vbd_to_remove = [] then raise (failwith "Disk not found") else let vbd = List.nth vbd_to_remove 0 in @@ -5071,7 +5065,7 @@ let vm_cd_add printer rpc session_id params = ) vdis in - if List.length vdis = 0 then failwith ("CD " ^ cd_name ^ " not found!") ; + if vdis = [] then failwith ("CD " ^ cd_name ^ " not found!") ; let vdi = List.nth vdis 0 in let op vm = create_vbd_and_plug rpc session_id (vm.getref ()) vdi @@ -5094,9 +5088,14 @@ let vm_cd_eject printer rpc session_id params = (fun vbd -> Client.VBD.get_type ~rpc ~session_id ~self:vbd = `CD) vbds in - if List.length cdvbds = 0 then failwith "No CDs found" ; - if List.length cdvbds > 1 then - failwith "Two or more CDs found. Please use vbd-eject" ; + ( match cdvbds with + | [] -> + failwith "No CDs found" + | [_] -> + () + | _ :: _ :: _ -> + failwith "Two or more CDs found. Please use vbd-eject" + ) ; let cd = List.hd cdvbds in Client.VBD.eject ~rpc ~session_id ~vbd:cd in @@ -5113,13 +5112,18 @@ let vm_cd_insert printer rpc session_id params = ) vdis in - if List.length vdis = 0 then failwith ("CD " ^ cd_name ^ " not found") ; - if List.length vdis > 1 then - failwith - ("Multiple CDs named " - ^ cd_name - ^ " found. Please use vbd-insert and specify uuids" - ) ; + ( match vdis with + | [] -> + failwith ("CD " ^ cd_name ^ " not found") + | [_] -> + () + | _ :: _ :: _ -> + failwith + ("Multiple CDs named " + ^ cd_name + ^ " found. Please use vbd-insert and specify uuids" + ) + ) ; let op vm = let vm_record = vm.record () in let vbds = vm_record.API.vM_VBDs in @@ -5131,15 +5135,16 @@ let vm_cd_insert printer rpc session_id params = ) vbds in - if List.length cdvbds = 0 then - raise - (Api_errors.Server_error - (Api_errors.vm_no_empty_cd_vbd, [Ref.string_of (vm.getref ())]) - ) ; - if List.length cdvbds > 1 then - failwith "Two or more empty CD devices found. Please use vbd-insert" ; - let cd = List.hd cdvbds in - Client.VBD.insert ~rpc ~session_id ~vbd:cd ~vdi:(List.hd vdis) + match cdvbds with + | [] -> + raise + (Api_errors.Server_error + (Api_errors.vm_no_empty_cd_vbd, [Ref.string_of (vm.getref ())]) + ) + | [cd] -> + Client.VBD.insert ~rpc ~session_id ~vbd:cd ~vdi:(List.hd vdis) + | _ :: _ :: _ -> + failwith "Two or more empty CD devices found. Please use vbd-insert" in ignore (do_vm_op printer rpc session_id op params ["cd-name"]) @@ -5555,7 +5560,7 @@ let pool_retrieve_wlb_report fd _printer rpc session_id params = in download_file_with_task fd rpc session_id filename Constants.wlb_report_uri (Printf.sprintf "report=%s%s%s" (Http.urlencode report) - (if List.length other_params = 0 then "" else "&") + (if other_params = [] then "" else "&") (String.concat "&" (List.map (fun (k, v) -> @@ -5978,7 +5983,7 @@ let vm_is_bios_customized printer rpc session_id params = let bios_strings = Client.VM.get_bios_strings ~rpc ~session_id ~self:(vm.getref ()) in - if List.length bios_strings = 0 then + if bios_strings = [] then printer (Cli_printer.PMsg "The BIOS strings of this VM have not yet been set.") else if bios_strings = Constants.generic_bios_strings then @@ -7259,7 +7264,7 @@ let subject_role_common rpc session_id params = let roles = Client.Role.get_by_name_label ~rpc ~session_id ~label:role_name in - if List.length roles > 0 then + if roles <> [] then List.hd roles (* names are unique, there's either 0 or 1*) else Ref.null diff --git a/ocaml/xapi-cli-server/cli_printer.ml b/ocaml/xapi-cli-server/cli_printer.ml index 5aace44caa1..1fc1d5586fd 100644 --- a/ocaml/xapi-cli-server/cli_printer.ml +++ b/ocaml/xapi-cli-server/cli_printer.ml @@ -56,7 +56,8 @@ let make_printer sock minimal = let multi_line_xapi_minimal pval = match pval with | PTable rs -> - if List.length rs > 0 && List.length (List.hd rs) > 0 then + (* Check that all the sublists aren't empty before calling List.hd *) + if rs <> [] && List.for_all (fun r -> r <> []) rs then let names = List.map (fun r -> snd (List.hd r)) rs in let escaped_names = List.map escape_commas names in buffer := String.concat "," escaped_names :: !buffer diff --git a/ocaml/xapi-idl/lib_test/updates_test.ml b/ocaml/xapi-idl/lib_test/updates_test.ml index c9604b35b52..66c5f09450e 100644 --- a/ocaml/xapi-idl/lib_test/updates_test.ml +++ b/ocaml/xapi-idl/lib_test/updates_test.ml @@ -35,7 +35,7 @@ let test_add () = let test_noadd () = let u = M.empty scheduler in let _barriers, updates, _id = M.get "dbg" None (Some 0) u in - assert_bool "Update returned" (List.length updates = 0) + assert_bool "Update returned" (updates = []) (* Tests that we can remove an update, and that it's not then returned by 'get' *) let test_remove () = @@ -43,7 +43,7 @@ let test_remove () = M.add update_a u ; M.remove update_a u ; let _barriers, updates, _id = M.get "dbg" None (Some 0) u in - assert_bool "Update returned" (List.length updates = 0) + assert_bool "Update returned" (updates = []) (* Tests that, if we specify a timeout, the 'get' call returns the empty list after that timeout. *) @@ -53,7 +53,7 @@ let test_timeout () = let _, l, _ = M.get "dbg" None (Some 1) u in let duration = Unix.gettimeofday () -. before in assert_bool "Duration greater than 1 sec" (duration > 1.0 && duration < 2.0) ; - assert_bool "Returned list was empty" (List.length l = 0) + assert_bool "Returned list was empty" (l = []) (* Checks that if we add an event after a blocking 'get' call that the call is unblocked. Verifies that the call returns immediately and that the correct @@ -112,7 +112,7 @@ let test_remove_barrier () = M.add update_c u ; M.remove_barrier 1 u ; let barriers, updates, _id = M.get "dbg" None (Some 1) u in - assert_bool "Barrier returned" (List.length barriers = 0) ; + assert_bool "Barrier returned" (barriers = []) ; assert_bool "Updates contain all updates" (List.nth updates 0 = update_b && List.nth updates 1 = update_a diff --git a/ocaml/xapi/create_misc.ml b/ocaml/xapi/create_misc.ml index a41f8a072e0..1b6e26ab84d 100644 --- a/ocaml/xapi/create_misc.ml +++ b/ocaml/xapi/create_misc.ml @@ -71,7 +71,7 @@ let make_xen_livepatch_list () = ) [] lines in - if List.length patches > 0 then Some (String.concat ", " patches) else None + if patches <> [] then Some (String.concat ", " patches) else None (** The format of the response looks like * # kpatch list @@ -104,7 +104,7 @@ let make_kpatch_list () = loop acc started rest in let patches = loop [] false lines in - if List.length patches > 0 then Some (String.concat ", " patches) else None + if patches <> [] then Some (String.concat ", " patches) else None (** [count_cpus] returns the number of CPUs found in /proc/cpuinfo *) let count_cpus () = diff --git a/ocaml/xapi/create_storage.ml b/ocaml/xapi/create_storage.ml index cc982db4800..19aff8ecbbd 100644 --- a/ocaml/xapi/create_storage.ml +++ b/ocaml/xapi/create_storage.ml @@ -90,7 +90,7 @@ let maybe_create_pbd rpc session_id sr device_config me = ) else pbds in - if List.length pbds = 0 (* If there's no PBD, create it *) then + if pbds = [] (* If there's no PBD, create it *) then Client.PBD.create ~rpc ~session_id ~host:me ~sR:sr ~device_config ~other_config:[] else diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index ba58ddd7b92..2af8173d202 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -1192,7 +1192,7 @@ let gethostbyname_family host family = Unix.getaddrinfo host "" [Unix.AI_SOCKTYPE Unix.SOCK_STREAM; Unix.AI_FAMILY family] in - if List.length he = 0 then + if he = [] then throw_resolve_error () ; Unix.string_of_inet_addr (getaddr (List.hd he).Unix.ai_addr) diff --git a/ocaml/xapi/map_check.ml b/ocaml/xapi/map_check.ml index d907f31090a..0cb2d97e37f 100644 --- a/ocaml/xapi/map_check.ml +++ b/ocaml/xapi/map_check.ml @@ -132,7 +132,7 @@ let with_ks ~kss ~fn = let corrected_values = List.filter (fun cv -> cv <> None) (List.map (fun ks -> fn field ks) kss) in - if List.length corrected_values < 1 then + if corrected_values = [] then [] else match List.hd corrected_values with None -> [] | Some cv -> cv diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 6be9f50d4c0..0beeee3f8ab 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -4527,7 +4527,7 @@ functor info "Bond.create: network = '%s'; members = [ %s ]" (network_uuid ~__context network) (String.concat "; " (List.map (pif_uuid ~__context) members)) ; - if List.length members = 0 then + if members = [] then raise (Api_errors.Server_error (Api_errors.pif_bond_needs_more_members, []) ) ; diff --git a/ocaml/xapi/workload_balancing.ml b/ocaml/xapi/workload_balancing.ml index 2d8300c45f1..be73658daf2 100644 --- a/ocaml/xapi/workload_balancing.ml +++ b/ocaml/xapi/workload_balancing.ml @@ -142,7 +142,7 @@ let is_childless elem = | Xml.Element (_, _, [Xml.PCData _]) -> true | Xml.Element (_, _, children) -> - List.length children = 0 + children = [] | Xml.PCData _ -> true diff --git a/ocaml/xapi/xapi_bond.ml b/ocaml/xapi/xapi_bond.ml index 20764394b36..173a789ac2b 100644 --- a/ocaml/xapi/xapi_bond.ml +++ b/ocaml/xapi/xapi_bond.ml @@ -98,7 +98,7 @@ let get_local_vifs ~__context host networks = false else let hosts = Xapi_vm.get_possible_hosts ~__context ~vm in - (List.mem host hosts && List.length hosts = 1) || List.length hosts = 0 + (List.mem host hosts && List.length hosts = 1) || hosts = [] in (* Make a list of the VIFs for local VMs *) let vms = Hashtbl.to_seq_keys vms_with_vifs |> List.of_seq in diff --git a/ocaml/xapi/xapi_ha.ml b/ocaml/xapi/xapi_ha.ml index 2295651ed05..9937fea6f28 100644 --- a/ocaml/xapi/xapi_ha.ml +++ b/ocaml/xapi/xapi_ha.ml @@ -1777,7 +1777,7 @@ let enable __context heartbeat_srs configuration = ) ) in - if List.length unplugged_ununpluggable_pifs > 0 then + if unplugged_ununpluggable_pifs <> [] then raise (Api_errors.Server_error ( Api_errors.required_pif_is_unplugged @@ -1804,7 +1804,7 @@ let enable __context heartbeat_srs configuration = ) not_bond_slaves in - if List.length without_disallow_unplug > 0 then ( + if without_disallow_unplug <> [] then ( let pifinfo = List.map (fun (pif, pifr) -> @@ -1874,7 +1874,7 @@ let enable __context heartbeat_srs configuration = else heartbeat_srs in - if List.length possible_srs = 0 then + if possible_srs = [] then raise (Api_errors.Server_error (Api_errors.cannot_create_state_file, [])) ; (* For the moment we'll create a state file in one compatible SR since the xHA component only handles one *) let srs = [List.hd possible_srs] in diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 01b76be3d85..897e4674332 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -199,7 +199,7 @@ let assert_bacon_mode ~__context ~host = |> List.flatten |> List.filter (fun self -> Db.VBD.get_currently_attached ~__context ~self) in - if List.length control_domain_vbds > 0 then + if control_domain_vbds <> [] then raise (Api_errors.Server_error ( Api_errors.host_in_use @@ -1093,7 +1093,7 @@ let destroy ~__context ~self = if Db.Pool.get_ha_enabled ~__context ~self:pool then raise (Api_errors.Server_error (Api_errors.ha_is_enabled, [])) ; let my_control_domains, my_regular_vms = get_resident_vms ~__context ~self in - if List.length my_regular_vms > 0 then + if my_regular_vms <> [] then raise (Api_errors.Server_error (Api_errors.host_has_resident_vms, [Ref.string_of self]) diff --git a/ocaml/xapi/xapi_network.ml b/ocaml/xapi/xapi_network.ml index bb641e980c2..3aefbad3be8 100644 --- a/ocaml/xapi/xapi_network.ml +++ b/ocaml/xapi/xapi_network.ml @@ -108,7 +108,7 @@ let attach_internal ?(management_interface = false) ?(force_bringup = false) ) else ( (* Ensure internal bridge exists and is up. external bridges will be brought up through Nm.bring_pif_up. *) - if List.length local_pifs = 0 then + if local_pifs = [] then create_internal_bridge ~__context ~bridge:net.API.network_bridge ~uuid:net.API.network_uuid ~persist ; (* Check if we're a Host-Internal Management Network (HIMN) (a.k.a. guest-installer network) *) diff --git a/ocaml/xapi/xapi_pbd.ml b/ocaml/xapi/xapi_pbd.ml index 4b6b5c22711..67fc069c8df 100644 --- a/ocaml/xapi/xapi_pbd.ml +++ b/ocaml/xapi/xapi_pbd.ml @@ -234,7 +234,7 @@ let unplug ~__context ~self = (fun vdi -> Db.VDI.get_type ~__context ~self:vdi <> `metadata) vdis in - if List.length non_metadata_vdis > 0 then + if non_metadata_vdis <> [] then raise (Api_errors.Server_error (Api_errors.vdi_in_use, List.map Ref.string_of non_metadata_vdis) diff --git a/ocaml/xapi/xapi_pgpu_helpers.ml b/ocaml/xapi/xapi_pgpu_helpers.ml index dc49ec33a83..77f5ee7282f 100644 --- a/ocaml/xapi/xapi_pgpu_helpers.ml +++ b/ocaml/xapi/xapi_pgpu_helpers.ml @@ -133,7 +133,7 @@ let get_remaining_capacity_internal ~__context ~self ~vgpu_type List.exists (fun (_, pgpu) -> pgpu = self) pre_allocate_list in let pci = Db.PGPU.get_PCI ~__context ~self in - let scheduled = List.length (get_scheduled_VGPUs ~__context ~self) > 0 in + let scheduled = get_scheduled_VGPUs ~__context ~self <> [] in let attached = Db.PCI.get_attached_VMs ~__context ~self:pci <> [] in convert_capacity (if scheduled || attached || pre_allocated then 0L else 1L) diff --git a/ocaml/xapi/xapi_pif.ml b/ocaml/xapi/xapi_pif.ml index f7bbd19ae19..d6d7a16a692 100644 --- a/ocaml/xapi/xapi_pif.ml +++ b/ocaml/xapi/xapi_pif.ml @@ -704,7 +704,7 @@ let create_VLAN ~__context ~device ~network ~host ~vLAN = ) other_pifs in - if List.length base_pifs = 0 then + if base_pifs = [] then raise (Api_errors.Server_error (Api_errors.invalid_value, ["device"; device])) ; let tagged_PIF = List.hd base_pifs in diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index 2d3a13304c7..da7991167db 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -356,7 +356,7 @@ let pre_join_checks ~__context ~rpc ~session_id ~force = ) my_vms in - if List.length my_running_vms > 0 then ( + if my_running_vms <> [] then ( error "The current host has running or suspended VMs: it cannot join a new \ pool" ; @@ -369,11 +369,9 @@ let pre_join_checks ~__context ~rpc ~session_id ~force = let assert_no_vms_with_current_ops () = let my_vms = Db.VM.get_all_records ~__context in let vms_with_current_ops = - List.filter - (fun (_, vmr) -> List.length vmr.API.vM_current_operations > 0) - my_vms + List.filter (fun (_, vmr) -> vmr.API.vM_current_operations <> []) my_vms in - if List.length vms_with_current_ops > 0 then ( + if vms_with_current_ops <> [] then ( error "The current host has VMs with current operations: it cannot join a \ new pool" ; @@ -2680,7 +2678,7 @@ let enable_external_auth ~__context ~pool:_ ~config ~service_name ~auth_type = !_rollback_list in (* 3. if any failed, then do a best-effort rollback, disabling any host that has been just enabled *) - if List.length rollback_list > 0 then (* FAILED *) + if rollback_list <> [] then (* FAILED *) let failed_host = (* the failed host is the first item in the rollback list *) List.hd rollback_list @@ -2803,7 +2801,7 @@ let disable_external_auth ~__context ~pool:_ ~config = let failedhosts_list = List.filter (fun (_, err, _) -> err <> "") host_msgs_list in - if List.length failedhosts_list > 0 then ((* FAILED *) + if failedhosts_list <> [] then ((* FAILED *) match List.hd failedhosts_list with | host, err, msg -> debug @@ -3073,7 +3071,7 @@ let enable_local_storage_caching ~__context ~self:_ = failed ) in - if List.length failed_hosts > 0 then + if failed_hosts <> [] then raise (Api_errors.Server_error ( Api_errors.hosts_failed_to_enable_caching @@ -3097,7 +3095,7 @@ let disable_local_storage_caching ~__context ~self:_ = hosts ) in - if List.length failed_hosts > 0 then + if failed_hosts <> [] then raise (Api_errors.Server_error ( Api_errors.hosts_failed_to_disable_caching diff --git a/ocaml/xapi/xapi_pool_update.ml b/ocaml/xapi/xapi_pool_update.ml index 1a9b8544bad..a7ec305a9a6 100644 --- a/ocaml/xapi/xapi_pool_update.ml +++ b/ocaml/xapi/xapi_pool_update.ml @@ -608,7 +608,7 @@ let pool_apply ~__context ~self = ) unapplied_hosts [] in - if List.length failed_hosts > 0 then + if failed_hosts <> [] then raise (Api_errors.Server_error (Api_errors.update_pool_apply_failed, failed_hosts) diff --git a/ocaml/xapi/xapi_pvs_proxy.ml b/ocaml/xapi/xapi_pvs_proxy.ml index 136daeef4be..3f81ffc783e 100644 --- a/ocaml/xapi/xapi_pvs_proxy.ml +++ b/ocaml/xapi/xapi_pvs_proxy.ml @@ -25,7 +25,7 @@ let create ~__context ~site ~vIF = Xapi_database.Db_filter_types.(Eq (Field "VIF", Literal (Ref.string_of vIF))) in let proxies = Db.PVS_proxy.get_refs_where ~__context ~expr in - if List.length proxies > 0 then + if proxies <> [] then raise Api_errors.( Server_error (pvs_proxy_already_present, List.map Ref.string_of proxies) diff --git a/ocaml/xapi/xapi_role.ml b/ocaml/xapi/xapi_role.ml index f63f13caa74..6e562023ceb 100644 --- a/ocaml/xapi/xapi_role.ml +++ b/ocaml/xapi/xapi_role.ml @@ -193,7 +193,7 @@ let get_is_internal ~__context ~self = let get_permissions_common ~__context ~role ~ret_value_fn = let rec rec_get_permissions_of_role ~__context ~role = let subroles = get_subroles ~__context ~self:role in - if List.length subroles = 0 then + if subroles = [] then (* base case = leaf node = permission is role itself *) [ret_value_fn role] else (* step = go recursively down composite roles *) @@ -233,7 +233,7 @@ let get_by_permission ~__context ~permission = let get_by_permission_name_label ~__context ~label = let permission = let ps = get_by_name_label ~__context ~label in - if List.length ps > 0 then + if ps <> [] then List.hd ps (* names are unique, there's either 0 or 1*) else Ref.null diff --git a/ocaml/xapi/xapi_session.ml b/ocaml/xapi/xapi_session.ml index c0341cecf37..1417b4d8313 100644 --- a/ocaml/xapi/xapi_session.ml +++ b/ocaml/xapi/xapi_session.ml @@ -522,7 +522,7 @@ let revalidate_external_session ~__context ~session = in debug "verified intersection for session %s, sid %s " (trackid session) authenticated_user_sid ; - let in_intersection = List.length intersection > 0 in + let in_intersection = intersection <> [] in if not in_intersection then ( (* empty intersection: externally-authenticated subject no longer has login rights in the pool *) let msg = @@ -1012,7 +1012,7 @@ let login_with_password ~__context ~uname ~pwd ~version:_ ~originator = intersect reflexive_membership_closure subject_ids_in_db in (* 2.3. finally, we create the session for the authenticated subject if any membership intersection was found *) - let in_intersection = List.length intersection > 0 in + let in_intersection = intersection <> [] in if not in_intersection then ( (* empty intersection: externally-authenticated subject has no login rights in the pool *) let msg = @@ -1053,7 +1053,7 @@ let login_with_password ~__context ~uname ~pwd ~version:_ ~originator = get_permissions ~__context ~subject_membership in (* CP-1260: If a subject has no roles assigned, then authentication will fail with an error such as PERMISSION_DENIED.*) - if List.length rbac_permissions < 1 then ( + if rbac_permissions = [] then ( let msg = Printf.sprintf "Subject %s (identifier %s) has no roles in this \ diff --git a/ocaml/xapi/xapi_sr.ml b/ocaml/xapi/xapi_sr.ml index 18cba6800aa..7b5186d5195 100644 --- a/ocaml/xapi/xapi_sr.ml +++ b/ocaml/xapi/xapi_sr.ml @@ -151,7 +151,7 @@ let scan_all ~__context = ) srs in - if List.length scannable_srs > 0 then + if scannable_srs <> [] then debug "Automatically scanning SRs = [ %s ]" (String.concat ";" (List.map Ref.string_of scannable_srs)) ; List.iter (scan_one ~__context) scannable_srs diff --git a/ocaml/xapi/xapi_sr_operations.ml b/ocaml/xapi/xapi_sr_operations.ml index 5d4cc834750..55c0d6805c6 100644 --- a/ocaml/xapi/xapi_sr_operations.ml +++ b/ocaml/xapi/xapi_sr_operations.ml @@ -146,10 +146,10 @@ let valid_operations ~__context ?op record _ref' : table = ) ) in - if List.length all_pbds_attached_to_this_sr > 0 then - set_errors Api_errors.sr_has_pbd [_ref] [`destroy; `forget] - else + if all_pbds_attached_to_this_sr = [] then () + else + set_errors Api_errors.sr_has_pbd [_ref] [`destroy; `forget] in let check_no_pbds ~__context _record = (* If the SR has no PBDs, destroy is not allowed. *) diff --git a/ocaml/xapi/xapi_vdi.ml b/ocaml/xapi/xapi_vdi.ml index 6a2fa244c84..f2f1ed12688 100644 --- a/ocaml/xapi/xapi_vdi.ml +++ b/ocaml/xapi/xapi_vdi.ml @@ -123,7 +123,7 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = []) ) pbd_records in - if List.length pbds_attached = 0 && List.mem op [`resize] then + if pbds_attached = [] && List.mem op [`resize] then Some (Api_errors.sr_no_pbds, [Ref.string_of sr]) else (* check to see whether VBDs exist which are using this VDI *) diff --git a/ocaml/xapi/xapi_vm_appliance_lifecycle.ml b/ocaml/xapi/xapi_vm_appliance_lifecycle.ml index ea752291a49..330d028cf1c 100644 --- a/ocaml/xapi/xapi_vm_appliance_lifecycle.ml +++ b/ocaml/xapi/xapi_vm_appliance_lifecycle.ml @@ -18,11 +18,11 @@ let check_operation_error ~__context record self op = let _ref = Ref.string_of self in let current_ops = record.Db_actions.vM_appliance_current_operations in (* Only allow one operation of [`start | `clean_shutdown | `hard_shutdown | `shutdown ] at a time. *) - if List.length current_ops > 0 then + if current_ops <> [] then Some (Api_errors.other_operation_in_progress, ["VM_appliance"; _ref]) else let vms = Db.VM_appliance.get_VMs ~__context ~self in - if List.length vms = 0 then + if vms = [] then Some (Api_errors.operation_not_allowed, ["Appliance has no VMs."]) else (* Allow the op if any VMs are in a state where the op makes sense. *) let power_states = diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index d8b9855686e..fc393be0252 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -1484,7 +1484,7 @@ let assert_valid_bios_strings ~__context ~value = let copy_bios_strings ~__context ~vm ~host = (* only allow to fill in BIOS strings if they are not yet set *) let current_strings = Db.VM.get_bios_strings ~__context ~self:vm in - if List.length current_strings > 0 then + if current_strings <> [] then raise (Api_errors.Server_error (Api_errors.vm_bios_strings_already_set, [])) else let bios_strings = Db.Host.get_bios_strings ~__context ~self:host in diff --git a/ocaml/xapi/xapi_vmss.ml b/ocaml/xapi/xapi_vmss.ml index 46599f129ad..03badb83b60 100644 --- a/ocaml/xapi/xapi_vmss.ml +++ b/ocaml/xapi/xapi_vmss.ml @@ -240,12 +240,11 @@ let destroy_all_messages ~__context ~self = let destroy ~__context ~self = assert_licensed ~__context ; let vms = Db.VMSS.get_VMs ~__context ~self in - if List.length vms > 0 then (* we can't delete a VMSS that contains VMs *) - raise (Api_errors.Server_error (Api_errors.vmss_has_vm, [])) - else ( + if vms = [] then ( destroy_all_messages ~__context ~self ; Db.VMSS.destroy ~__context ~self - ) + ) else (* we can't delete a VMSS that contains VMs *) + raise (Api_errors.Server_error (Api_errors.vmss_has_vm, [])) (* Verify if snapshot is happening due to a VM Schedule Snapshot *) let is_vmss_snapshot ~__context = diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 33bcbb7a958..4a45462095f 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -3049,7 +3049,7 @@ let resync_resident_on ~__context = in (* Log the state before we do anything *) let maybe_log_em msg prefix l = - if List.length l > 0 then ( + if l <> [] then ( debug "%s" msg ; List.iter (fun ((id, _), queue) -> debug "%s %s (%s)" prefix id queue) l ) @@ -3067,7 +3067,7 @@ let resync_resident_on ~__context = nowhere." "In xenopsd but resident nowhere: " xapi_thinks_are_nowhere ; (* This is pretty bad! *) - if List.length xapi_vms_not_in_xenopsd > 0 then ( + if xapi_vms_not_in_xenopsd <> [] then ( debug "The following VMs are not known to xenopsd, but xapi thought they \ should have been" ; diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index 6768c413c73..e038b402c6d 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -811,7 +811,7 @@ let main () = let args, traceparent = parse_args args in (* All the named args are taken as permitted filename to be uploaded *) let permitted_filenames = get_permit_filenames args in - if List.length args < 1 then + if args = [] then raise Usage else with_open_channels @@ fun (ic, oc) -> diff --git a/ocaml/xen-api-client/async_examples/event_test.ml b/ocaml/xen-api-client/async_examples/event_test.ml index 18b6c5a319d..7107a8bda8f 100644 --- a/ocaml/xen-api-client/async_examples/event_test.ml +++ b/ocaml/xen-api-client/async_examples/event_test.ml @@ -74,7 +74,7 @@ let watch_events rpc session_id = Event.from ~rpc ~session_id ~classes:["*"] ~token:"" ~timeout:0. >>= fun rpc -> let e = event_from_of_rpc rpc in - if List.length e.events = 0 then error "Empty list of events" ; + if List.is_empty e.events then error "Empty list of events" ; let current = List.fold_left ~init:StringMap.empty ~f:update e.events in Sequence.iter ~f:(fun (key, diff) -> diff --git a/ocaml/xenopsd/test/test.ml b/ocaml/xenopsd/test/test.ml index cc373222c41..befadd5e739 100644 --- a/ocaml/xenopsd/test/test.ml +++ b/ocaml/xenopsd/test/test.ml @@ -85,7 +85,7 @@ let wait_for_tasks id = (List.length deltas) ; flush stderr ) ; - if List.length deltas = 0 then + if deltas = [] then failwith (Printf.sprintf "no deltas, next_id = %d" next_id) ; event_id := Some next_id ; List.iter diff --git a/ocaml/xenopsd/xc/domain.ml b/ocaml/xenopsd/xc/domain.ml index f78e7179e6a..540e1a13652 100644 --- a/ocaml/xenopsd/xc/domain.ml +++ b/ocaml/xenopsd/xc/domain.ml @@ -797,7 +797,7 @@ let destroy (task : Xenops_task.task_handle) ~xc ~xs ~qemu_domid ~vtpm ~dm domid cleanup. If there are any remaining domains with the same UUID, then zap only the hotplug tree for the destroyed domain. *) if failed_devices = [] then - if List.length other_domains < 1 then + if other_domains = [] then log_exn_rm ~xs (Device_common.get_private_path_by_uuid uuid) else log_exn_rm ~xs (Hotplug.get_hotplug_base_by_uuid uuid domid) ; diff --git a/ocaml/xenopsd/xc/hotplug.ml b/ocaml/xenopsd/xc/hotplug.ml index 06a4edec85d..1eac8c8a7e0 100644 --- a/ocaml/xenopsd/xc/hotplug.ml +++ b/ocaml/xenopsd/xc/hotplug.ml @@ -286,10 +286,11 @@ let release (task : Xenops_task.task_handle) ~xc ~xs (x : device) = and the private path is indexed by UUID, not domid. *) let vm_uuid = Xenops_helpers.uuid_of_domid ~xs x.frontend.domid in let domains_of_vm = Xenops_helpers.domains_of_uuid ~xc vm_uuid in - if List.length domains_of_vm <= 1 then - Some (get_private_data_path_of_device x) - else - None + match domains_of_vm with + | [] | [_] -> + Some (get_private_data_path_of_device x) + | _ :: _ :: _ -> + None in let extra_xenserver_path = extra_xenserver_path_of_device ~xs x in Xs.transaction xs (fun t -> diff --git a/quality-gate.sh b/quality-gate.sh index b504ed69d1b..33f54e26e54 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=312 + N=308 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" @@ -93,6 +93,26 @@ ocamlyacc () { fi } +unnecessary-length () { + N=0 + local_grep () { + git grep -r -o --count "$1" -- '**/*.ml' | wc -l + } + UNNECESSARY_LENGTH=$(local_grep "List.length.*=+\s*0") + UNNECESSARY_LENGTH=$((UNNECESSARY_LENGTH+$(local_grep "0\s*=+\s*List.length"))) + UNNECESSARY_LENGTH=$((UNNECESSARY_LENGTH+$(local_grep "List.length.*\s>\s*0"))) + UNNECESSARY_LENGTH=$((UNNECESSARY_LENGTH+$(local_grep "0\s*<\s*List.length"))) + UNNECESSARY_LENGTH=$((UNNECESSARY_LENGTH+$(local_grep "List.length.*\s<\s*1"))) + UNNECESSARY_LENGTH=$((UNNECESSARY_LENGTH+$(local_grep "1\s*>\s*List.length"))) + if [ "$UNNECESSARY_LENGTH" -eq "$N" ]; then + echo "OK found $UNNECESSARY_LENGTH unnecessary usages of List.length in OCaml files." + else + echo "ERROR expected $N unnecessary usages of List.length in OCaml files, + got $UNNECESSARY_LENGTH. Use lst =/<> [] or match statements instead." 1>&2 + exit 1 + fi +} + list-hd verify-cert mli-files @@ -100,4 +120,5 @@ structural-equality vtpm-unimplemented vtpm-fields ocamlyacc +unnecessary-length From 99c43569a02cbfd7d4635309cd5b9a517f0d99f0 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 19 Jun 2024 16:34:20 +0100 Subject: [PATCH 28/44] Transition from exception-raising Unix.getenv to Sys.getenv_opt with explicit handling of failure cases. OCaml's stdlib has Sys.getenv_opt since 4.05. Some of the newer code already uses it, and some of the old code handled exceptions (so could nicely be transitioned to handling options instead). Some, however, did not handle failure at all. This commit remedies that. In most cases, getenv is used to query the PATH variable (before adding another directory to it, for example), in which case there is a nice default value of "". In some cases, the environment variable is required to be present to proceed, then there is a failure of some kind raised with the appropriate message. A test case was added to the quality-gate.sh script to prevent introduction of the exception-raising Unix.getenv into new code. Signed-off-by: Andrii Sultanov --- ocaml/libs/stunnel/stunnel.ml | 54 +++++++++++-------- ocaml/networkd/lib/network_utils.ml | 6 ++- ocaml/tapctl/tapctl.ml | 11 ++-- ocaml/xapi-idl/lib/coverage/enabled.ml | 11 ++-- ocaml/xapi-idl/lib/xcp_service.ml | 20 ++++--- .../org.xen.xcp.storage.plainlvm/common.ml | 12 +++-- ocaml/xapi/helpers.ml | 6 ++- ocaml/xapi/xapi_host.ml | 2 +- ocaml/xapi/xapi_support.ml | 2 +- ocaml/xapi/xha_scripts.ml | 8 ++- ocaml/xe-cli/newcli.ml | 4 +- ocaml/xe-cli/options.ml | 2 +- ocaml/xenopsd/cli/xn.ml | 3 +- ocaml/xsh/xsh.ml | 6 ++- quality-gate.sh | 12 +++++ 15 files changed, 108 insertions(+), 51 deletions(-) diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index aaaf3dd7d2a..7003efe2d9f 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -35,27 +35,38 @@ let stunnel_logger = ref ignore let timeoutidle = ref None let init_stunnel_path () = - try cached_stunnel_path := Some (Unix.getenv "XE_STUNNEL") - with Not_found -> - let choices = - [ - "/opt/xensource/libexec/stunnel/stunnel" - ; "/usr/sbin/stunnel4" - ; "/usr/sbin/stunnel" - ; "/usr/bin/stunnel4" - ; "/usr/bin/stunnel" - ] - in - let rec choose l = - match l with - | [] -> - raise Stunnel_binary_missing - | p :: ps -> ( - try Unix.access p [Unix.X_OK] ; p with _ -> choose ps + cached_stunnel_path := + Some + ( match Sys.getenv_opt "XE_STUNNEL" with + | Some x -> + x + | None -> + let choices = + [ + "/opt/xensource/libexec/stunnel/stunnel" + ; "/usr/sbin/stunnel4" + ; "/usr/sbin/stunnel" + ; "/usr/bin/stunnel4" + ; "/usr/bin/stunnel" + ] + in + + let choose l = + match + List.find_opt + (fun el -> + try Unix.access el [Unix.X_OK] ; true with _ -> false + ) + l + with + | Some p -> + p + | None -> + raise Stunnel_binary_missing + in + let path = choose choices in + path ) - in - let path = choose choices in - cached_stunnel_path := Some path let stunnel_path () = if Option.is_none !cached_stunnel_path then @@ -150,7 +161,8 @@ let debug_conf_of_bool verbose : string = if verbose then "debug=authpriv.7" else "debug=authpriv.5" let debug_conf_of_env () : string = - (try Unix.getenv "debug_stunnel" with _ -> "") |> String.lowercase_ascii + Option.value (Sys.getenv_opt "debug_stunnel") ~default:"" + |> String.lowercase_ascii |> fun x -> List.mem x ["yes"; "true"; "1"] |> debug_conf_of_bool let config_file ?(accept = None) config host port = diff --git a/ocaml/networkd/lib/network_utils.ml b/ocaml/networkd/lib/network_utils.ml index 1c7479e83e5..fe371e694de 100644 --- a/ocaml/networkd/lib/network_utils.ml +++ b/ocaml/networkd/lib/network_utils.ml @@ -112,7 +112,11 @@ let check_n_run ?(on_error = default_error_handler) ?(log = true) run_func try Unix.access script [Unix.X_OK] ; (* Use the same $PATH as xapi *) - let env = [|"PATH=" ^ Sys.getenv "PATH"|] in + let env = + Option.fold ~none:[||] + ~some:(fun p -> [|"PATH=" ^ p|]) + (Sys.getenv_opt "PATH") + in if log then info "%s %s" script (String.concat " " args) ; run_func env script args diff --git a/ocaml/tapctl/tapctl.ml b/ocaml/tapctl/tapctl.ml index 109e95df3f6..5e043c49270 100644 --- a/ocaml/tapctl/tapctl.ml +++ b/ocaml/tapctl/tapctl.ml @@ -336,9 +336,12 @@ let canonicalise x = if not (Filename.is_relative x) then x else (* Search the PATH and XCP_PATH for the executable *) - let paths = Astring.String.cuts ~sep:":" ~empty:false (Sys.getenv "PATH") in + let path_env_var = Option.value (Sys.getenv_opt "PATH") ~default:"" in + let paths = Astring.String.cuts ~sep:":" ~empty:false path_env_var in let xen_paths = - try Astring.String.cuts ~sep:":" ~empty:false (Sys.getenv "XCP_PATH") + try + Astring.String.cuts ~sep:":" ~empty:false + (Option.value (Sys.getenv_opt "XCP_PATH") ~default:"") with _ -> [] in let first_hit = @@ -361,7 +364,9 @@ let canonicalise x = let tap_ctl = canonicalise "tap-ctl" let invoke_tap_ctl _ cmd args = - let find x = try [x ^ "=" ^ Sys.getenv x] with _ -> [] in + let find x = + match Sys.getenv_opt x with Some v -> [x ^ "=" ^ v] | None -> [] + in let env = Array.of_list (find "PATH" @ find "TAPDISK" @ find "TAPDISK2") in let stdout, _ = execute_command_get_output ~env tap_ctl (cmd :: args) in stdout diff --git a/ocaml/xapi-idl/lib/coverage/enabled.ml b/ocaml/xapi-idl/lib/coverage/enabled.ml index ac128055d75..461221db512 100644 --- a/ocaml/xapi-idl/lib/coverage/enabled.ml +++ b/ocaml/xapi-idl/lib/coverage/enabled.ml @@ -9,7 +9,13 @@ module Bisect = struct let bisect_file = "BISECT_FILE" let dump jobid = - let bisect_prefix = Unix.getenv bisect_file in + let bisect_prefix = + match Sys.getenv_opt bisect_file with + | Some x -> + x + | None -> + D.warn "No $BISECT_FILE default set: %s" __LOC__ + in (* dump coverage information in same location as it would normally get dumped on exit, except also embed the jobid to make it easier to group. Relies on [open_temp_file] generating a unique filename given a @@ -39,8 +45,7 @@ module Bisect = struct let init_env name = let ( // ) = Filename.concat in let tmpdir = Filename.get_temp_dir_name () in - try ignore (Sys.getenv bisect_file) - with Not_found -> + if Option.is_none (Sys.getenv_opt bisect_file) then Unix.putenv bisect_file (tmpdir // Printf.sprintf "bisect-%s-" name) let process body = diff --git a/ocaml/xapi-idl/lib/xcp_service.ml b/ocaml/xapi-idl/lib/xcp_service.ml index 123acd4a249..d0cfc658de2 100644 --- a/ocaml/xapi-idl/lib/xcp_service.ml +++ b/ocaml/xapi-idl/lib/xcp_service.ml @@ -364,24 +364,22 @@ let canonicalise x = if not (Filename.is_relative x) then x else (* Search the PATH and XCP_PATH for the executable *) - let paths = split_c ':' (Sys.getenv "PATH") in + let paths = + split_c ':' (Option.value (Sys.getenv_opt "PATH") ~default:"") + in let first_hit = - List.fold_left - (fun found path -> - match found with - | Some _hit -> - found - | None -> - let possibility = Filename.concat path x in - if Sys.file_exists possibility then Some possibility else None + List.find_opt + (fun path -> + let possibility = Filename.concat path x in + Sys.file_exists possibility ) - None (paths @ !extra_search_path) in match first_hit with | None -> warn "Failed to find %s on $PATH ( = %s) or search_path option ( = %s)" - x (Sys.getenv "PATH") + x + (Option.value (Sys.getenv_opt "PATH") ~default:"unset") (String.concat ":" !extra_search_path) ; x | Some hit -> diff --git a/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml b/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml index fe7b15258aa..298099be057 100644 --- a/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml +++ b/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml @@ -126,9 +126,13 @@ let canonicalise x = if not (Filename.is_relative x) then x else (* Search the PATH and XCP_PATH for the executable *) - let paths = Re_str.split colon (Sys.getenv "PATH") in + let paths = + Re_str.split colon (Option.value (Sys.getenv_opt "PATH") ~default:"") + in let xen_paths = - try Re_str.split colon (Sys.getenv "XCP_PATH") with _ -> [] + try + Re_str.split colon (Option.value (Sys.getenv_opt "XCP_PATH") ~default:"") + with _ -> [] in let first_hit = List.fold_left @@ -148,8 +152,8 @@ let canonicalise x = match first_hit with | None -> warn "Failed to find %s on $PATH ( = %s) or $XCP_PATH ( = %s)" x - (Sys.getenv "PATH") - (try Sys.getenv "XCP_PATH" with Not_found -> "unset") ; + (Option.value (Sys.getenv_opt "PATH") ~default:"unset") + (Option.value (Sys.getenv_opt "XCP_PATH") ~default:"unset") ; x | Some hit -> hit diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 69e2ba3ce24..e8ef361edf4 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -85,7 +85,11 @@ let call_script ?(log_output = Always) ?env ?stdin ?timeout script args = Unix.access script [Unix.X_OK] ; (* Use the same $PATH as xapi *) let env = - match env with None -> [|"PATH=" ^ Sys.getenv "PATH"|] | Some env -> env + match env with + | None -> + [|"PATH=" ^ Option.value (Sys.getenv_opt "PATH") ~default:""|] + | Some env -> + env in let output, _ = match stdin with diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 7e767dbd035..a0958a8dd21 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -123,7 +123,7 @@ let bugreport_upload ~__context ~host:_ ~url ~options = if List.mem_assoc "http_proxy" options then List.assoc "http_proxy" options else - try Unix.getenv "http_proxy" with _ -> "" + Option.value (Sys.getenv_opt "http_proxy") ~default:"" in let cmd = Printf.sprintf "%s %s %s" diff --git a/ocaml/xapi/xapi_support.ml b/ocaml/xapi/xapi_support.ml index 7d073b33020..5e65d586776 100644 --- a/ocaml/xapi/xapi_support.ml +++ b/ocaml/xapi/xapi_support.ml @@ -29,7 +29,7 @@ let do_upload label file url options = if List.mem_assoc "http_proxy" options then List.assoc "http_proxy" options else - try Unix.getenv "http_proxy" with _ -> "" + Option.value (Sys.getenv_opt "http_proxy") ~default:"" in let env = Helpers.env_with_path [("URL", url); ("PROXY", proxy)] in match diff --git a/ocaml/xapi/xha_scripts.ml b/ocaml/xapi/xha_scripts.ml index f5c2cae514e..c8f87e412c1 100644 --- a/ocaml/xapi/xha_scripts.ml +++ b/ocaml/xapi/xha_scripts.ml @@ -60,7 +60,13 @@ let ha_script_m = Mutex.create () let call_script ?log_output script args = let path = ha_dir () in let script' = Filename.concat path script in - let env = [|Printf.sprintf "PATH=%s:%s" (Sys.getenv "PATH") path|] in + let env = + [| + Printf.sprintf "PATH=%s:%s" + (Option.value (Sys.getenv_opt "PATH") ~default:"") + path + |] + in try Xapi_stdext_threads.Threadext.Mutex.execute ha_script_m (fun () -> Helpers.call_script ?log_output ~env script' args diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index 3cf21e39abb..a10225cebc0 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -280,7 +280,9 @@ let parse_args = (List.filter (fun (k, v) -> not (set_keyword (k, v))) rcs) in let extras = - let extra_args = try Sys.getenv "XE_EXTRA_ARGS" with Not_found -> "" in + let extra_args = + Option.value (Sys.getenv_opt "XE_EXTRA_ARGS") ~default:"" + in let l = ref [] and pos = ref 0 and i = ref 0 in while !pos < String.length extra_args do if extra_args.[!pos] = ',' then ( diff --git a/ocaml/xe-cli/options.ml b/ocaml/xe-cli/options.ml index e089a30c164..f19067bf3fa 100644 --- a/ocaml/xe-cli/options.ml +++ b/ocaml/xe-cli/options.ml @@ -34,7 +34,7 @@ let parse_lines ls = let read_rc () = try - let home = Sys.getenv "HOME" in + let home = Option.value (Sys.getenv_opt "HOME") ~default:"" in let rc_file = open_in (home ^ "/.xe") in let rec getlines cur = try diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index 0eb6ef5ac1b..a8b10706504 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -1061,7 +1061,8 @@ let xenconsoles = let vncviewer_binary = let n = "vncviewer" in let dirs = - Re.Str.split_delim (Re.Str.regexp_string ":") (Unix.getenv "PATH") + Re.Str.split_delim (Re.Str.regexp_string ":") + (Option.value (Sys.getenv_opt "PATH") ~default:"") in List.fold_left (fun result dir -> diff --git a/ocaml/xsh/xsh.ml b/ocaml/xsh/xsh.ml index 4f563373857..982ff6c346f 100644 --- a/ocaml/xsh/xsh.ml +++ b/ocaml/xsh/xsh.ml @@ -100,7 +100,11 @@ let _ = let host = Sys.argv.(1) in let cmd = Sys.argv.(2) in let session = - try Sys.getenv "XSH_SESSION" with _ -> failwith "Session not provided" + match Sys.getenv_opt "XSH_SESSION" with + | Some x -> + x + | None -> + failwith "Session not provided" in let args = List.map diff --git a/quality-gate.sh b/quality-gate.sh index b504ed69d1b..f12113a215f 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -93,6 +93,17 @@ ocamlyacc () { fi } +unixgetenv () { + N=1 + UNIXGETENV=$(git grep -P -r -o --count 'getenv(?!_opt)' -- **/*.ml | wc -l) + if [ "$UNIXGETENV" -eq "$N" ]; then + echo "OK found $UNIXGETENV usages of exception-raising Unix.getenv in OCaml files." + else + echo "ERROR expected $N usages of exception-raising Unix.getenv in OCaml files, got $UNIXGETENV" 1>&2 + exit 1 + fi +} + list-hd verify-cert mli-files @@ -100,4 +111,5 @@ structural-equality vtpm-unimplemented vtpm-fields ocamlyacc +unixgetenv From 7be240fa5817bd728a1c3897fe223c4e1618ef56 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 26 Jun 2024 16:34:35 +0100 Subject: [PATCH 29/44] Replace Hashtbl.find with Hashtbl.find_opt in trivial cases This avoids two traversals in the cases where Hashtbl.mem is used right before Hashtbl.find: avoiding two traversals, possible data races and the possibility where one would be changed without the other, introducing bugs. Additionally, it handles failure explicitly where it wasn't handled before, and moves from exception handling to matching on options resulting in intentions becoming clearer. This commit only changes trivial cases where little refactoring was necessary. Signed-off-by: Andrii Sultanov --- configure.ml | 17 ++-- ocaml/database/db_backend.ml | 5 +- ocaml/database/db_conn_store.ml | 14 ++-- ocaml/database/stats.ml | 7 +- ocaml/idl/dtd_backend.ml | 15 ++-- ocaml/libs/http-lib/http_svr.ml | 7 +- ocaml/libs/http-lib/mime.ml | 2 +- ocaml/libs/stunnel/stunnel_cache.ml | 7 +- .../vhd/vhd_format_lwt_test/parse_test.ml | 13 ++-- ocaml/libs/xapi-inventory/lib/inventory.ml | 8 +- ocaml/message-switch/core/make.ml | 12 +-- ocaml/message-switch/switch/mswitch.ml | 5 +- ocaml/message-switch/unix/protocol_unix.ml | 12 +-- ocaml/networkd/bin/network_monitor_thread.ml | 70 ++++++++--------- ocaml/perftest/tests.ml | 6 +- ocaml/rrd2csv/src/rrd2csv.ml | 46 +++++------ ocaml/sdk-gen/csharp/gen_csharp_binding.ml | 4 +- ocaml/squeezed/lib/squeeze.ml | 36 +++++---- ocaml/squeezed/src/squeeze_xen.ml | 24 +++--- ocaml/tapctl/tapctl.ml | 7 +- ocaml/tests/test_xapi_vbd_helpers.ml | 8 +- ocaml/xapi-cli-server/cli_frontend.ml | 76 +++++++++--------- ocaml/xapi-cli-server/cli_operations.ml | 4 +- ocaml/xapi-cli-server/cli_util.ml | 49 ++++++------ ocaml/xapi-idl/lib/xcp_service.ml | 3 + ocaml/xapi-storage-script/main.ml | 14 ++-- ocaml/xapi/binpack.ml | 12 +-- ocaml/xapi/db_gc.ml | 19 ++--- ocaml/xapi/db_gc_util.ml | 15 ++-- ocaml/xapi/eventgen.ml | 7 +- ocaml/xapi/export.ml | 9 ++- ocaml/xapi/helpers.ml | 9 ++- ocaml/xapi/localdb.ml | 16 ++-- ocaml/xapi/monitor_dbcalls_cache.ml | 16 ++-- ocaml/xapi/rbac.ml | 10 ++- ocaml/xapi/slave_backup.ml | 16 ++-- ocaml/xapi/sm.ml | 9 ++- ocaml/xapi/storage_access.ml | 2 +- ocaml/xapi/storage_migrate.ml | 2 +- ocaml/xapi/storage_mux.ml | 49 +++++++----- ocaml/xapi/storage_smapiv1.ml | 11 ++- ocaml/xapi/storage_smapiv1_wrapper.ml | 23 +++--- ocaml/xapi/system_domains.ml | 2 +- ocaml/xapi/xapi_dr.ml | 7 +- ocaml/xapi/xapi_event.ml | 77 ++++++++++--------- ocaml/xapi/xapi_guest_agent.ml | 50 ++++++------ ocaml/xapi/xapi_ha_vm_failover.ml | 9 ++- ocaml/xapi/xapi_host_helpers.ml | 29 +++---- ocaml/xapi/xapi_pci_helpers.ml | 10 ++- ocaml/xapi/xapi_pool_helpers.ml | 29 +++---- ocaml/xapi/xapi_pool_update.ml | 8 +- ocaml/xapi/xapi_role.ml | 44 +++++------ ocaml/xapi/xapi_sr_operations.ml | 31 ++++---- ocaml/xapi/xapi_vbd_helpers.ml | 31 ++++---- ocaml/xapi/xapi_vdi_helpers.ml | 38 ++++----- ocaml/xapi/xapi_vif_helpers.ml | 28 +++---- ocaml/xapi/xapi_vm.ml | 10 +-- ocaml/xapi/xapi_vusb_helpers.ml | 29 +++---- ocaml/xapi/xapi_xenops.ml | 12 +-- ocaml/xapi/xha_interface.ml | 57 ++++++++------ ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml | 7 +- ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml | 61 +++++++-------- ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml | 75 +++++++++--------- ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml | 8 +- ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml | 22 +++--- ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml | 5 +- ocaml/xcp-rrdd/lib/rrdd/stats.ml | 15 ++-- ocaml/xenopsd/list_domains/list_domains.ml | 8 +- ocaml/xenopsd/xc/device.ml | 5 +- ocaml/xenopsd/xc/readln.ml | 4 +- ocaml/xenopsd/xc/stats.ml | 15 ++-- ocaml/xenopsd/xc/xenops_server_xen.ml | 5 +- 72 files changed, 740 insertions(+), 687 deletions(-) diff --git a/configure.ml b/configure.ml index cfd797beb6b..e5c37d55fbc 100644 --- a/configure.ml +++ b/configure.ml @@ -84,11 +84,12 @@ let () = in List.iter print_endline lines ; (* Expand @LIBEXEC@ in udev rules *) - try - let xenopsd_libexecdir = Hashtbl.find config "XENOPSD_LIBEXECDIR" in - expand "@LIBEXEC@" xenopsd_libexecdir "ocaml/xenopsd/scripts/vif.in" - "ocaml/xenopsd/scripts/vif" ; - expand "@LIBEXEC@" xenopsd_libexecdir - "ocaml/xenopsd/scripts/xen-backend.rules.in" - "ocaml/xenopsd/scripts/xen-backend.rules" - with Not_found -> failwith "xenopsd_libexecdir not set" + match Hashtbl.find_opt config "XENOPSD_LIBEXECDIR" with + | Some xenopsd_libexecdir -> + expand "@LIBEXEC@" xenopsd_libexecdir "ocaml/xenopsd/scripts/vif.in" + "ocaml/xenopsd/scripts/vif" ; + expand "@LIBEXEC@" xenopsd_libexecdir + "ocaml/xenopsd/scripts/xen-backend.rules.in" + "ocaml/xenopsd/scripts/xen-backend.rules" + | None -> + failwith "xenopsd_libexecdir not set" diff --git a/ocaml/database/db_backend.ml b/ocaml/database/db_backend.ml index c5270f68169..92954540c33 100644 --- a/ocaml/database/db_backend.ml +++ b/ocaml/database/db_backend.ml @@ -104,8 +104,5 @@ let is_session_registered session = let get_registered_database session = with_lock db_registration_mutex (fun () -> - if Hashtbl.mem foreign_databases session then - Some (Hashtbl.find foreign_databases session) - else - None + Hashtbl.find_opt foreign_databases session ) diff --git a/ocaml/database/db_conn_store.ml b/ocaml/database/db_conn_store.ml index 0bf1536649e..035020695a0 100644 --- a/ocaml/database/db_conn_store.ml +++ b/ocaml/database/db_conn_store.ml @@ -41,12 +41,14 @@ let read_db_connections () = !db_connections let with_db_conn_lock db_conn f = let db_conn_m = with_lock db_conn_locks_m (fun () -> - try Hashtbl.find db_conn_locks db_conn - with _ -> - (* If we don't have a lock already for this connection then go make one dynamically and use that from then on *) - let new_dbconn_mutex = Mutex.create () in - Hashtbl.replace db_conn_locks db_conn new_dbconn_mutex ; - new_dbconn_mutex + match Hashtbl.find_opt db_conn_locks db_conn with + | Some x -> + x + | None -> + (* If we don't have a lock already for this connection then go make one dynamically and use that from then on *) + let new_dbconn_mutex = Mutex.create () in + Hashtbl.replace db_conn_locks db_conn new_dbconn_mutex ; + new_dbconn_mutex ) in with_lock db_conn_m (fun () -> f ()) diff --git a/ocaml/database/stats.ml b/ocaml/database/stats.ml index 8e7711810c8..8bf4f55de4d 100644 --- a/ocaml/database/stats.ml +++ b/ocaml/database/stats.ml @@ -77,10 +77,9 @@ let sample (name : string) (x : float) : unit = let x' = log x in with_lock timings_m (fun () -> let p = - if Hashtbl.mem timings name then - Hashtbl.find timings name - else - Normal_population.empty + Option.value + (Hashtbl.find_opt timings name) + ~default:Normal_population.empty in let p' = Normal_population.sample p x' in Hashtbl.replace timings name p' diff --git a/ocaml/idl/dtd_backend.ml b/ocaml/idl/dtd_backend.ml index e94cf4a9178..c3b79e91f54 100644 --- a/ocaml/idl/dtd_backend.ml +++ b/ocaml/idl/dtd_backend.ml @@ -110,14 +110,13 @@ let rec strings_of_dtd_element known_els = function let element known_els name children atts = let existing_children = - if Hashtbl.mem known_els name then - match Hashtbl.find known_els name with - | Element (_, c, att) -> - (c, att) - | _ -> - assert false - else - ([], []) + match Hashtbl.find_opt known_els name with + | Some (Element (_, c, att)) -> + (c, att) + | None -> + ([], []) + | _ -> + assert false in let open Xapi_stdext_std.Listext in let el = diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index c824277e5be..e19d1a230e0 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -651,8 +651,11 @@ exception Socket_not_found (* Stop an HTTP server running on a socket *) let stop (socket, _name) = let server = - try Hashtbl.find socket_table socket - with Not_found -> raise Socket_not_found + match Hashtbl.find_opt socket_table socket with + | Some x -> + x + | None -> + raise Socket_not_found in Hashtbl.remove socket_table socket ; server.Server_io.shutdown () diff --git a/ocaml/libs/http-lib/mime.ml b/ocaml/libs/http-lib/mime.ml index c48599c65ad..e8dabaca132 100644 --- a/ocaml/libs/http-lib/mime.ml +++ b/ocaml/libs/http-lib/mime.ml @@ -42,7 +42,7 @@ let default_mime = "text/plain" (** Map a file extension to a MIME type *) let mime_of_ext mime ext = - try Hashtbl.find mime (lowercase ext) with Not_found -> default_mime + Option.value (Hashtbl.find_opt mime (lowercase ext)) ~default:default_mime (** Figure out a mime type from a full filename *) let mime_of_file_name mime fname = diff --git a/ocaml/libs/stunnel/stunnel_cache.ml b/ocaml/libs/stunnel/stunnel_cache.ml index eaf85be89a0..57f361d26ce 100644 --- a/ocaml/libs/stunnel/stunnel_cache.ml +++ b/ocaml/libs/stunnel/stunnel_cache.ml @@ -187,12 +187,7 @@ let add (x : Stunnel.t) = ; verified= x.Stunnel.verified } in - let existing = - if Hashtbl.mem !index ep then - Hashtbl.find !index ep - else - [] - in + let existing = Option.value (Hashtbl.find_opt !index ep) ~default:[] in Hashtbl.replace !index ep (idx :: existing) ; debug "Adding stunnel id %s (idle %.2f) to the cache" (id_of_stunnel x) 0. ; unlocked_gc () diff --git a/ocaml/libs/vhd/vhd_format_lwt_test/parse_test.ml b/ocaml/libs/vhd/vhd_format_lwt_test/parse_test.ml index 02d9b32d456..458c0c7cce6 100644 --- a/ocaml/libs/vhd/vhd_format_lwt_test/parse_test.ml +++ b/ocaml/libs/vhd/vhd_format_lwt_test/parse_test.ml @@ -173,12 +173,13 @@ let initial = {to_close= []; to_unlink= []; child= None; contents= []} let sectors = Hashtbl.create 16 let sector_lookup message = - if Hashtbl.mem sectors message then - Hashtbl.find sectors message - else - let data = fill_sector_with message in - Hashtbl.replace sectors message data ; - data + match Hashtbl.find_opt sectors message with + | Some x -> + x + | None -> + let data = fill_sector_with message in + Hashtbl.replace sectors message data ; + data let execute state = function | Create size -> diff --git a/ocaml/libs/xapi-inventory/lib/inventory.ml b/ocaml/libs/xapi-inventory/lib/inventory.ml index 374780a09f8..867d4a2483e 100644 --- a/ocaml/libs/xapi-inventory/lib/inventory.ml +++ b/ocaml/libs/xapi-inventory/lib/inventory.ml @@ -116,14 +116,16 @@ exception Missing_inventory_key of string let lookup ?default key = M.execute inventory_m (fun () -> if not !loaded_inventory then read_inventory_contents () ; - if Hashtbl.mem inventory key then - Hashtbl.find inventory key - else + match Hashtbl.find_opt inventory key with + | Some x -> + x + | None -> ( match default with | None -> raise (Missing_inventory_key key) | Some v -> v + ) ) let flush_to_disk_locked () = diff --git a/ocaml/message-switch/core/make.ml b/ocaml/message-switch/core/make.ml index 224012909ac..43b7e301a9b 100644 --- a/ocaml/message-switch/core/make.ml +++ b/ocaml/message-switch/core/make.ml @@ -189,14 +189,14 @@ functor (fun (i, m) -> M.Mutex.with_lock requests_m (fun () -> match m.Message.kind with - | Message.Response j -> - if Hashtbl.mem wakener j then + | Message.Response j -> ( + match Hashtbl.find_opt wakener j with + | Some x -> let rec loop events_conn = Connection.rpc events_conn (In.Ack i) >>= function | Ok (_ : string) -> - M.Ivar.fill (Hashtbl.find wakener j) (Ok m) ; - return (Ok ()) + M.Ivar.fill x (Ok m) ; return (Ok ()) | Error _ -> reconnect () >>|= fun (requests_conn, events_conn) -> @@ -205,7 +205,7 @@ functor loop events_conn in loop events_conn - else ( + | None -> Printf.printf "no wakener for id %s, %Ld\n%!" (fst i) (snd i) ; Hashtbl.iter @@ -216,7 +216,7 @@ functor ) wakener ; return (Ok ()) - ) + ) | Message.Request _ -> return (Ok ()) ) diff --git a/ocaml/message-switch/switch/mswitch.ml b/ocaml/message-switch/switch/mswitch.ml index fe57a978382..b674ae65059 100644 --- a/ocaml/message-switch/switch/mswitch.ml +++ b/ocaml/message-switch/switch/mswitch.ml @@ -65,10 +65,7 @@ end let next_transfer_expected : (string, int64) Hashtbl.t = Hashtbl.create 128 let get_next_transfer_expected name = - if Hashtbl.mem next_transfer_expected name then - Some (Hashtbl.find next_transfer_expected name) - else - None + Hashtbl.find_opt next_transfer_expected name let record_transfer time name = Hashtbl.replace next_transfer_expected name time diff --git a/ocaml/message-switch/unix/protocol_unix.ml b/ocaml/message-switch/unix/protocol_unix.ml index 485964a40ec..a9b4984e4f4 100644 --- a/ocaml/message-switch/unix/protocol_unix.ml +++ b/ocaml/message-switch/unix/protocol_unix.ml @@ -294,17 +294,17 @@ module Client = struct (* If the Ack doesn't belong to us then assume it's another thread *) IO.Mutex.with_lock requests_m (fun () -> match m.Message.kind with - | Message.Response j -> - if Hashtbl.mem wakener j then ( + | Message.Response j -> ( + match Hashtbl.find_opt wakener j with + | Some x -> do_rpc t.events_conn (In.Ack i) >>|= fun (_ : string) -> - IO.Ivar.fill (Hashtbl.find wakener j) (Ok m) ; - Ok () - ) else ( + IO.Ivar.fill x (Ok m) ; Ok () + | None -> Printf.printf "no wakener for id %s,%Ld\n%!" (fst i) (snd i) ; Ok () - ) + ) | Message.Request _ -> Ok () ) diff --git a/ocaml/networkd/bin/network_monitor_thread.ml b/ocaml/networkd/bin/network_monitor_thread.ml index 7ec920f329c..43b471be21a 100644 --- a/ocaml/networkd/bin/network_monitor_thread.ml +++ b/ocaml/networkd/bin/network_monitor_thread.ml @@ -63,43 +63,41 @@ let send_bond_change_alert _dev interfaces message = let check_for_changes ~(dev : string) ~(stat : Network_monitor.iface_stats) = let open Network_monitor in match Astring.String.is_prefix ~affix:"vif" dev with - | true -> - () - | false -> - if stat.nb_links > 1 then - if (* It is a bond. *) - Hashtbl.mem bonds_status dev then ( - (* Seen before. *) - let nb_links_old, links_up_old = Hashtbl.find bonds_status dev in - if links_up_old <> stat.links_up then ( - info "Bonds status changed: %s nb_links %d up %d up_old %d" dev - stat.nb_links stat.links_up links_up_old ; - Hashtbl.replace bonds_status dev (stat.nb_links, stat.links_up) ; - let msg = - Printf.sprintf "changed: %d/%d up (was %d/%d)" stat.links_up - stat.nb_links links_up_old nb_links_old - in - try send_bond_change_alert dev stat.interfaces msg - with e -> - debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" - (Printexc.to_string e) - (Printexc.get_backtrace ()) - ) - ) else ( - (* Seen for the first time. *) - Hashtbl.add bonds_status dev (stat.nb_links, stat.links_up) ; - info "New bonds status: %s nb_links %d up %d" dev stat.nb_links - stat.links_up ; - if stat.links_up <> stat.nb_links then - let msg = - Printf.sprintf "is: %d/%d up" stat.links_up stat.nb_links - in - try send_bond_change_alert dev stat.interfaces msg - with e -> - debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" - (Printexc.to_string e) - (Printexc.get_backtrace ()) + | false when stat.nb_links > 1 -> ( + (* It is a bond. *) + match Hashtbl.find_opt bonds_status dev with + | Some (nb_links_old, links_up_old) -> + (* Seen before. *) + if links_up_old <> stat.links_up then ( + info "Bonds status changed: %s nb_links %d up %d up_old %d" dev + stat.nb_links stat.links_up links_up_old ; + Hashtbl.replace bonds_status dev (stat.nb_links, stat.links_up) ; + let msg = + Printf.sprintf "changed: %d/%d up (was %d/%d)" stat.links_up + stat.nb_links links_up_old nb_links_old + in + try send_bond_change_alert dev stat.interfaces msg + with e -> + debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" + (Printexc.to_string e) + (Printexc.get_backtrace ()) ) + | None -> ( + (* Seen for the first time. *) + Hashtbl.add bonds_status dev (stat.nb_links, stat.links_up) ; + info "New bonds status: %s nb_links %d up %d" dev stat.nb_links + stat.links_up ; + if stat.links_up <> stat.nb_links then + let msg = Printf.sprintf "is: %d/%d up" stat.links_up stat.nb_links in + try send_bond_change_alert dev stat.interfaces msg + with e -> + debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" + (Printexc.to_string e) + (Printexc.get_backtrace ()) + ) + ) + | _ -> + () let failed_again = ref false diff --git a/ocaml/perftest/tests.ml b/ocaml/perftest/tests.ml index 5262d4be0ec..d0463e9f60a 100644 --- a/ocaml/perftest/tests.ml +++ b/ocaml/perftest/tests.ml @@ -112,13 +112,13 @@ let parallel_with_vms async_op opname n vms rpc session_id test subtest_name = List.iter (fun task -> if List.mem task !active_tasks then ( - ( if not (Hashtbl.mem tasks_to_vm task) then + ( match Hashtbl.find_opt tasks_to_vm task with + | None -> debug ~out:stderr "Ignoring completed task which doesn't correspond to a \ VM %s" opname - else - let uuid = Hashtbl.find tasks_to_vm task in + | Some uuid -> let started = Hashtbl.find vm_to_start_time uuid in let time_taken = Unix.gettimeofday () -. started in results := time_taken :: !results ; diff --git a/ocaml/rrd2csv/src/rrd2csv.ml b/ocaml/rrd2csv/src/rrd2csv.ml index 4e36e581e5b..13fdef256c4 100644 --- a/ocaml/rrd2csv/src/rrd2csv.ml +++ b/ocaml/rrd2csv/src/rrd2csv.ml @@ -110,30 +110,32 @@ let vm_uuid_to_name_label_map = Hashtbl.create 20 let host_uuid_to_name_label_map = Hashtbl.create 10 let get_vm_name_label vm_uuid = - if Hashtbl.mem vm_uuid_to_name_label_map vm_uuid then - Hashtbl.find vm_uuid_to_name_label_map vm_uuid - else - let name_label, _session_id = - XAPI.retry_with_session - (fun session_id () -> XAPI.get_vm_name_label ~session_id ~uuid:vm_uuid) - () - in - Hashtbl.replace vm_uuid_to_name_label_map vm_uuid name_label ; - name_label + match Hashtbl.find_opt vm_uuid_to_name_label_map vm_uuid with + | Some x -> + x + | None -> + let name_label, _session_id = + XAPI.retry_with_session + (fun session_id () -> XAPI.get_vm_name_label ~session_id ~uuid:vm_uuid) + () + in + Hashtbl.replace vm_uuid_to_name_label_map vm_uuid name_label ; + name_label let get_host_name_label host_uuid = - if Hashtbl.mem host_uuid_to_name_label_map host_uuid then - Hashtbl.find host_uuid_to_name_label_map host_uuid - else - let name_label, _session_id = - XAPI.retry_with_session - (fun session_id () -> - XAPI.get_host_name_label ~session_id ~uuid:host_uuid - ) - () - in - Hashtbl.replace host_uuid_to_name_label_map host_uuid name_label ; - name_label + match Hashtbl.find_opt host_uuid_to_name_label_map host_uuid with + | Some x -> + x + | None -> + let name_label, _session_id = + XAPI.retry_with_session + (fun session_id () -> + XAPI.get_host_name_label ~session_id ~uuid:host_uuid + ) + () + in + Hashtbl.replace host_uuid_to_name_label_map host_uuid name_label ; + name_label module Ds_selector = struct type t = { diff --git a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml index 21483260f5b..0c8b016cb5c 100644 --- a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml +++ b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml @@ -136,8 +136,8 @@ and gen_relations () = and process_relations ((oneClass, oneField), (manyClass, manyField)) = let value = - try (manyField, oneClass, oneField) :: Hashtbl.find relations manyClass - with Not_found -> [(manyField, oneClass, oneField)] + (manyField, oneClass, oneField) + :: Option.value (Hashtbl.find_opt relations manyClass) ~default:[] in Hashtbl.replace relations manyClass value diff --git a/ocaml/squeezed/lib/squeeze.ml b/ocaml/squeezed/lib/squeeze.ml index 30b203c7e8c..bb308c45639 100644 --- a/ocaml/squeezed/lib/squeeze.ml +++ b/ocaml/squeezed/lib/squeeze.ml @@ -171,16 +171,23 @@ module Stuckness_monitor = struct direction_of_actual domain.inaccuracy_kib domain.memory_actual_kib domain.target_kib in - if not (Hashtbl.mem x.per_domain domain.domid) then - Hashtbl.replace x.per_domain domain.domid - (* new domains are considered to be making progress now and not - stuck *) - { - last_actual_kib= domain.memory_actual_kib - ; last_makingprogress_time= now - ; stuck= false - } ; - let state = Hashtbl.find x.per_domain domain.domid in + let state = + match Hashtbl.find_opt x.per_domain domain.domid with + | Some x -> + x + | None -> + (* new domains are considered to be making + progress now and not stuck *) + let new_data = + { + last_actual_kib= domain.memory_actual_kib + ; last_makingprogress_time= now + ; stuck= false + } + in + Hashtbl.replace x.per_domain domain.domid new_data ; + new_data + in let delta_actual = domain.memory_actual_kib -* state.last_actual_kib in state.last_actual_kib <- domain.memory_actual_kib ; (* If memory_actual is moving towards the target then we say we are @@ -229,10 +236,11 @@ module Stuckness_monitor = struct progress. If it is not making progress it may have either hit its target or it may have failed. *) let domid_is_active (x : t) domid (_ : float) = - if not (Hashtbl.mem x.per_domain domid) then - false (* it must have been destroyed *) - else - not (Hashtbl.find x.per_domain domid).stuck + match Hashtbl.find_opt x.per_domain domid with + | Some x -> + not x.stuck + | None -> + false (* it must have been destroyed *) end type fistpoint = diff --git a/ocaml/squeezed/src/squeeze_xen.ml b/ocaml/squeezed/src/squeeze_xen.ml index f4ba7e5accd..496e7d03ea0 100644 --- a/ocaml/squeezed/src/squeeze_xen.ml +++ b/ocaml/squeezed/src/squeeze_xen.ml @@ -125,9 +125,8 @@ module Domain = struct (* get_per_domain can return None if the domain is deleted by someone else while we are processing some other event handlers *) let get_per_domain xc domid = - if Hashtbl.mem cache domid then - Some (Hashtbl.find cache domid) - else + match Hashtbl.find_opt cache domid with + | None -> ( try let path = Printf.sprintf "/local/domain/%d" domid in let di = Xenctrl.domain_getinfo xc domid in @@ -143,6 +142,9 @@ module Domain = struct Hashtbl.replace cache domid d ; Some d with Xenctrl.Error _ -> Hashtbl.remove cache domid ; None + ) + | x -> + x let remove_gone_domains_cache xc = let current_domains = Xenctrl.domain_getinfolist xc 0 in @@ -385,10 +387,11 @@ module Domain = struct match get_per_domain xc domid with | None -> None - | Some per_domain -> - if Hashtbl.mem per_domain.keys key then - Hashtbl.find per_domain.keys key - else + | Some per_domain -> ( + match Hashtbl.find_opt per_domain.keys key with + | Some x -> + x + | None -> let x = try Some @@ -400,6 +403,7 @@ module Domain = struct in Hashtbl.replace per_domain.keys key x ; x + ) ) in match x with Some y -> y | None -> raise (Xs_protocol.Enoent key) @@ -412,10 +416,8 @@ module Domain = struct | None -> () | Some per_domain -> ( - if - (not (Hashtbl.mem per_domain.keys key)) - || Hashtbl.find per_domain.keys key <> Some value - then + if Option.join (Hashtbl.find_opt per_domain.keys key) <> Some value then + (* Don't update if there is the same value bound already *) try Client.transaction (get_client ()) (fun t -> (* Fail if the directory has been deleted *) diff --git a/ocaml/tapctl/tapctl.ml b/ocaml/tapctl/tapctl.ml index 5e043c49270..075eea8aba2 100644 --- a/ocaml/tapctl/tapctl.ml +++ b/ocaml/tapctl/tapctl.ml @@ -339,10 +339,9 @@ let canonicalise x = let path_env_var = Option.value (Sys.getenv_opt "PATH") ~default:"" in let paths = Astring.String.cuts ~sep:":" ~empty:false path_env_var in let xen_paths = - try - Astring.String.cuts ~sep:":" ~empty:false - (Option.value (Sys.getenv_opt "XCP_PATH") ~default:"") - with _ -> [] + (* Can't raise an exception since the separator string isn't empty *) + Astring.String.cuts ~sep:":" ~empty:false + (Option.value (Sys.getenv_opt "XCP_PATH") ~default:"") in let first_hit = List.fold_left diff --git a/ocaml/tests/test_xapi_vbd_helpers.ml b/ocaml/tests/test_xapi_vbd_helpers.ml index 08ea79fda38..0aa4ef0a6d1 100644 --- a/ocaml/tests/test_xapi_vbd_helpers.ml +++ b/ocaml/tests/test_xapi_vbd_helpers.ml @@ -34,11 +34,9 @@ let run_assert_equal_with_vdi ~__context msg ?(expensive_sharing_checks = true) Xapi_vbd_helpers.valid_operations ~__context ~expensive_sharing_checks vbd_record vbd_ref in - match Hashtbl.find valid_ops op with - | Some (code, _) -> - Some code - | None -> - None + Option.map + (fun (code, _) -> code) + (Option.join (Hashtbl.find_opt valid_ops op)) in Alcotest.(check (option string)) msg expected_error_if_any (get_error_code_of op) diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index 3c2c617fddf..ca36ed76d82 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -3887,44 +3887,44 @@ let make_list l = let rio_help printer minimal cmd = let docmd cmd = - try - let cmd_spec = Hashtbl.find cmdtable cmd in - let vm_selectors = List.mem Vm_selectors cmd_spec.flags in - let host_selectors = List.mem Host_selectors cmd_spec.flags in - let sr_selectors = List.mem Sr_selectors cmd_spec.flags in - let optional = - cmd_spec.optn - @ (if vm_selectors then vmselectors else []) - @ (if sr_selectors then srselectors else []) - @ if host_selectors then hostselectors else [] - in - let desc = - match (vm_selectors, host_selectors, sr_selectors) with - | false, false, false -> - cmd_spec.help - | true, false, false -> - cmd_spec.help ^ vmselectorsinfo - | false, true, false -> - cmd_spec.help ^ hostselectorsinfo - | false, false, true -> - cmd_spec.help ^ srselectorsinfo - | _ -> - cmd_spec.help - (* never happens currently *) - in - let recs = - [ - ("command name ", cmd) - ; ("reqd params ", String.concat ", " cmd_spec.reqd) - ; ("optional params ", String.concat ", " optional) - ; ("description ", desc) - ] - in - printer (Cli_printer.PTable [recs]) - with Not_found as e -> - Debug.log_backtrace e (Backtrace.get e) ; - error "Responding with Unknown command %s" cmd ; - printer (Cli_printer.PList ["Unknown command '" ^ cmd ^ "'"]) + match Hashtbl.find_opt cmdtable cmd with + | Some cmd_spec -> + let vm_selectors = List.mem Vm_selectors cmd_spec.flags in + let host_selectors = List.mem Host_selectors cmd_spec.flags in + let sr_selectors = List.mem Sr_selectors cmd_spec.flags in + let optional = + cmd_spec.optn + @ (if vm_selectors then vmselectors else []) + @ (if sr_selectors then srselectors else []) + @ if host_selectors then hostselectors else [] + in + let desc = + match (vm_selectors, host_selectors, sr_selectors) with + | false, false, false -> + cmd_spec.help + | true, false, false -> + cmd_spec.help ^ vmselectorsinfo + | false, true, false -> + cmd_spec.help ^ hostselectorsinfo + | false, false, true -> + cmd_spec.help ^ srselectorsinfo + | _ -> + cmd_spec.help + (* never happens currently *) + in + let recs = + [ + ("command name ", cmd) + ; ("reqd params ", String.concat ", " cmd_spec.reqd) + ; ("optional params ", String.concat ", " optional) + ; ("description ", desc) + ] + in + printer (Cli_printer.PTable [recs]) + | None -> + D.log_backtrace () ; + error "Responding with Unknown command %s" cmd ; + printer (Cli_printer.PList ["Unknown command '" ^ cmd ^ "'"]) in let cmds = List.filter diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 6aee526f497..2e19df44a4c 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -650,7 +650,9 @@ let make_param_funs getallrecs getbyuuid record class_name def_filters set_in_map key v | None, Some set_map -> let existing_params = - try Hashtbl.find set_map_table set_map with Not_found -> [] + Option.value + (Hashtbl.find_opt set_map_table set_map) + ~default:[] in Hashtbl.replace set_map_table set_map ((key, v) :: existing_params) | None, None -> diff --git a/ocaml/xapi-cli-server/cli_util.ml b/ocaml/xapi-cli-server/cli_util.ml index 5d7e9ef3e6d..035494a2957 100644 --- a/ocaml/xapi-cli-server/cli_util.ml +++ b/ocaml/xapi-cli-server/cli_util.ml @@ -254,31 +254,30 @@ let ref_convert x = (* Marshal an API-style server-error *) let get_server_error code params = - try - let error = Hashtbl.find Datamodel.errors code in - (* There ought to be a bijection between parameters mentioned in - datamodel.ml and those in the exception but this is unchecked and - false in some cases, defined here. *) - let required = - if code = Api_errors.vms_failed_to_cooperate then - List.map (fun _ -> "VM") params - else - error.Datamodel_types.err_params - in - (* For the rest we attempt to pretty-print the list even when it's short/long *) - let rec pp_params = function - | t :: ts, v :: vs -> - (t ^ ": " ^ v) :: pp_params (ts, vs) - | [], v :: vs -> - (": " ^ v) :: pp_params ([], vs) - | t :: ts, [] -> - (t ^ ": ") :: pp_params (ts, []) - | [], [] -> - [] - in - let errparams = pp_params (required, List.map ref_convert params) in - Some (error.Datamodel_types.err_doc, errparams) - with _ -> None + let ( let* ) = Option.bind in + let* error = Hashtbl.find_opt Datamodel.errors code in + (* There ought to be a bijection between parameters mentioned in + datamodel.ml and those in the exception but this is unchecked and + false in some cases, defined here. *) + let required = + if code = Api_errors.vms_failed_to_cooperate then + List.map (fun _ -> "VM") params + else + error.Datamodel_types.err_params + in + (* For the rest we attempt to pretty-print the list even when it's short/long *) + let rec pp_params = function + | t :: ts, v :: vs -> + (t ^ ": " ^ v) :: pp_params (ts, vs) + | [], v :: vs -> + (": " ^ v) :: pp_params ([], vs) + | t :: ts, [] -> + (t ^ ": ") :: pp_params (ts, []) + | [], [] -> + [] + in + let errparams = pp_params (required, List.map ref_convert params) in + Some (error.Datamodel_types.err_doc, errparams) let server_error (code : string) (params : string list) sock = match get_server_error code params with diff --git a/ocaml/xapi-idl/lib/xcp_service.ml b/ocaml/xapi-idl/lib/xcp_service.ml index d0cfc658de2..667e51bd74f 100644 --- a/ocaml/xapi-idl/lib/xcp_service.ml +++ b/ocaml/xapi-idl/lib/xcp_service.ml @@ -365,6 +365,9 @@ let canonicalise x = x else (* Search the PATH and XCP_PATH for the executable *) let paths = + (* Might be worth eliminating split_c function (used in a few + more places in this module and replacing it with + Astring.String.cuts since it's already imported in this module *) split_c ':' (Option.value (Sys.getenv_opt "PATH") ~default:"") in let first_hit = diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index fbfc4796220..8b5673701ba 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -1644,13 +1644,13 @@ let watch_volume_plugins ~volume_root ~switch_path ~pipe = in let destroy volume_plugin_name = info "Removing %s" volume_plugin_name ; - if Hashtbl.mem servers volume_plugin_name then ( - let t = Hashtbl.find_exn servers volume_plugin_name in - Message_switch_async.Protocol_async.Server.shutdown ~t () >>= fun () -> - Hashtbl.remove servers volume_plugin_name ; - return () - ) else - return () + match Hashtbl.find servers volume_plugin_name with + | Some t -> + Message_switch_async.Protocol_async.Server.shutdown ~t () >>= fun () -> + Hashtbl.remove servers volume_plugin_name ; + return () + | None -> + return () in let sync () = Sys.readdir volume_root >>= fun names -> diff --git a/ocaml/xapi/binpack.ml b/ocaml/xapi/binpack.ml index cef4730b1cb..e89a775c749 100644 --- a/ocaml/xapi/binpack.ml +++ b/ocaml/xapi/binpack.ml @@ -51,11 +51,13 @@ let biggest_fit_decreasing (things : ('a * int64) list) let memoise f = let table = Hashtbl.create 10 in let rec lookup x = - if Hashtbl.mem table x then - Hashtbl.find table x - else - let result = f lookup x in - Hashtbl.add table x result ; result + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + let result = f lookup x in + Hashtbl.replace table x result ; + result in lookup diff --git a/ocaml/xapi/db_gc.ml b/ocaml/xapi/db_gc.ml index c7fb5d93373..a0442314448 100644 --- a/ocaml/xapi/db_gc.ml +++ b/ocaml/xapi/db_gc.ml @@ -91,12 +91,11 @@ let check_host_liveness ~__context = let live = Db.Host_metrics.get_live ~__context ~self:hmetric in (* See if the host is using the new HB mechanism, if so we'll use that *) let new_heartbeat_time = - try - with_lock host_table_m (fun () -> - Hashtbl.find host_heartbeat_table host - ) - with _ -> 0.0 - (* never *) + with_lock host_table_m (fun () -> + Option.value + (Hashtbl.find_opt host_heartbeat_table host) + ~default:Clock.Date.(epoch |> to_unix_time) + ) in let old_heartbeat_time = if @@ -141,11 +140,9 @@ let check_host_liveness ~__context = ) ; (* Check for clock skew *) detect_clock_skew ~__context host - ( try - with_lock host_table_m (fun () -> - Hashtbl.find host_skew_table host - ) - with _ -> 0. + (with_lock host_table_m (fun () -> + Option.value (Hashtbl.find_opt host_skew_table host) ~default:0. + ) ) with exn -> debug "Ignoring exception inspecting metrics of host %s: %s" diff --git a/ocaml/xapi/db_gc_util.ml b/ocaml/xapi/db_gc_util.ml index eb86d981291..182eaac00df 100644 --- a/ocaml/xapi/db_gc_util.ml +++ b/ocaml/xapi/db_gc_util.ml @@ -322,12 +322,13 @@ let timeout_tasks ~__context = let pending_old_run, pending_old_hung = List.partition (fun (_, t) -> - try - let pre_progress = - Hashtbl.find probation_pending_tasks t.Db_actions.task_uuid - in - t.Db_actions.task_progress -. pre_progress > min_float - with Not_found -> true + match + Hashtbl.find_opt probation_pending_tasks t.Db_actions.task_uuid + with + | Some pre_progress -> + t.Db_actions.task_progress -. pre_progress > min_float + | None -> + true ) pending_old in @@ -505,7 +506,7 @@ let timeout_sessions ~__context = `Name s.Db_actions.session_auth_user_name in let current_sessions = - try Hashtbl.find session_groups key with Not_found -> [] + Option.value (Hashtbl.find_opt session_groups key) ~default:[] in Hashtbl.replace session_groups key (rs :: current_sessions) ) diff --git a/ocaml/xapi/eventgen.ml b/ocaml/xapi/eventgen.ml index 274e74abb78..f03db1e9bed 100644 --- a/ocaml/xapi/eventgen.ml +++ b/ocaml/xapi/eventgen.ml @@ -22,10 +22,9 @@ let get_record_table : Hashtbl.create 20 let find_get_record x ~__context ~self () : Rpc.t option = - if Hashtbl.mem get_record_table x then - Some (Hashtbl.find get_record_table x ~__context ~self ()) - else - None + Option.map + (fun x -> x ~__context ~self ()) + (Hashtbl.find_opt get_record_table x) (* If a record is created or destroyed, then for any (Ref _) field which is one end of a relationship, need to send diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 326efdaf067..6cb156d21ca 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -157,10 +157,11 @@ let create_table () = Hashtbl.create 10 (** Convert an internal reference into an external one or NULL *) let lookup table r = - if not (Hashtbl.mem table r) then - Ref.null - else - Ref.of_string (Hashtbl.find table r) + match Hashtbl.find_opt table r with + | Some x -> + Ref.of_string x + | None -> + Ref.null (** Convert a list of internal references into external references, filtering out NULLs *) let filter table rs = diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index e8ef361edf4..4504e56fcdb 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -1572,9 +1572,12 @@ module Early_wakeup = struct let signal key = (*debug "Early_wakeup signal key = (%s, %s)" a b;*) with_lock table_m (fun () -> - if Hashtbl.mem table key then - (*debug "Signalling thread blocked on (%s,%s)" a b;*) - Delay.signal (Hashtbl.find table key) + Option.iter + (fun x -> + (*debug "Signalling thread blocked on (%s,%s)" a b;*) + Delay.signal x + ) + (Hashtbl.find_opt table key) ) end diff --git a/ocaml/xapi/localdb.ml b/ocaml/xapi/localdb.ml index 0cfa222138c..3382c42e32a 100644 --- a/ocaml/xapi/localdb.ml +++ b/ocaml/xapi/localdb.ml @@ -66,7 +66,11 @@ let m = Mutex.create () let get (key : string) = with_lock m (fun () -> assert_loaded () ; - try Hashtbl.find db key with Not_found -> raise (Missing_key key) + match Hashtbl.find_opt db key with + | Some x -> + x + | None -> + raise (Missing_key key) ) let get_with_default (key : string) (default : string) = @@ -74,11 +78,11 @@ let get_with_default (key : string) (default : string) = (* Returns true if a change was made and should be flushed *) let put_one (key : string) (v : string) = - if Hashtbl.mem db key && Hashtbl.find db key = v then - false (* no change necessary *) - else ( - Hashtbl.replace db key v ; true - ) + match Hashtbl.find_opt db key with + | Some x when x = v -> + false (* no change necessary *) + | _ -> + Hashtbl.replace db key v ; true let flush () = let b = Buffer.create 256 in diff --git a/ocaml/xapi/monitor_dbcalls_cache.ml b/ocaml/xapi/monitor_dbcalls_cache.ml index 507500b20dc..a0aad3d1766 100644 --- a/ocaml/xapi/monitor_dbcalls_cache.ml +++ b/ocaml/xapi/monitor_dbcalls_cache.ml @@ -96,8 +96,11 @@ let clear_cache () = let transfer_map ?(except = []) ~source ~target () = List.iter (fun ex -> - try Hashtbl.replace source ex (Hashtbl.find target ex) - with Not_found -> Hashtbl.remove source ex + match Hashtbl.find_opt target ex with + | Some elem -> + Hashtbl.replace source ex elem + | None -> + Hashtbl.remove source ex ) except ; Hashtbl.clear target ; @@ -107,10 +110,11 @@ let transfer_map ?(except = []) ~source ~target () = let get_updates ~before ~after ~f = Hashtbl.fold (fun k v acc -> - if try v <> Hashtbl.find before k with Not_found -> true then - f k v acc - else - acc + match Hashtbl.find_opt before k with + | Some x when v = x -> + acc + | _ -> + f k v acc ) after [] diff --git a/ocaml/xapi/rbac.ml b/ocaml/xapi/rbac.ml index c304b5a991d..5b442f11a4a 100644 --- a/ocaml/xapi/rbac.ml +++ b/ocaml/xapi/rbac.ml @@ -149,10 +149,12 @@ let is_permission_in_session ~session_id ~permission ~session = let find_linear elem set = List.exists (fun e -> e = elem) set in let find_log elem set = Permission_set.mem elem set in let permission_tree = - try Some (Hashtbl.find session_permissions_tbl session_id) - with Not_found -> - create_session_permissions_tbl ~session_id - ~rbac_permissions:session.API.session_rbac_permissions + match Hashtbl.find_opt session_permissions_tbl session_id with + | None -> + create_session_permissions_tbl ~session_id + ~rbac_permissions:session.API.session_rbac_permissions + | x -> + x in match permission_tree with | Some permission_tree -> diff --git a/ocaml/xapi/slave_backup.ml b/ocaml/xapi/slave_backup.ml index aeb3e3e1e95..6a8a41c8a90 100644 --- a/ocaml/xapi/slave_backup.ml +++ b/ocaml/xapi/slave_backup.ml @@ -34,13 +34,15 @@ let with_backup_lock f = Xapi_stdext_threads.Threadext.Mutex.execute backup_m f log it in table and return that *) (* IMPORTANT: must be holding backup_m mutex when you call this function.. *) let lookup_write_entry dbconn = - try Hashtbl.find backup_write_table dbconn - with _ -> - let new_write_entry = - {period_start_time= Unix.gettimeofday (); writes_this_period= 0} - in - Hashtbl.replace backup_write_table dbconn new_write_entry ; - new_write_entry + match Hashtbl.find_opt backup_write_table dbconn with + | Some x -> + x + | None -> + let new_write_entry = + {period_start_time= Unix.gettimeofday (); writes_this_period= 0} + in + Hashtbl.replace backup_write_table dbconn new_write_entry ; + new_write_entry (* Reset period_start_time, writes_this_period if period has expired *) let tick_backup_write_table () = diff --git a/ocaml/xapi/sm.ml b/ocaml/xapi/sm.ml index df438a656bd..40e9b11e3e2 100644 --- a/ocaml/xapi/sm.ml +++ b/ocaml/xapi/sm.ml @@ -50,10 +50,11 @@ let register ~__context () = let info_of_driver (name : string) = let name = String.lowercase_ascii name in - if not (Hashtbl.mem driver_info_cache name) then - raise (Unknown_driver name) - else - Hashtbl.find driver_info_cache name + match Hashtbl.find_opt driver_info_cache name with + | Some x -> + x + | None -> + raise (Unknown_driver name) let features_of_driver (name : string) = (info_of_driver name).sr_driver_features diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index 292c96b4f52..02e5545d16e 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -409,7 +409,7 @@ let remove_from_progress_map id = let get_progress_map id = with_lock progress_map_m (fun () -> - try Hashtbl.find progress_map_tbl id with _ -> fun x -> x + Option.value (Hashtbl.find_opt progress_map_tbl id) ~default:Fun.id ) let register_mirror __context mid = diff --git a/ocaml/xapi/storage_migrate.ml b/ocaml/xapi/storage_migrate.ml index eff980cfbe6..468cddb2bf0 100644 --- a/ocaml/xapi/storage_migrate.ml +++ b/ocaml/xapi/storage_migrate.ml @@ -258,7 +258,7 @@ module State = struct let find id table = access_table ~save_after:false - (fun table -> try Some (Hashtbl.find table id) with Not_found -> None) + (fun table -> Hashtbl.find_opt table id) table let remove id table = diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index 0dcef1d201f..3a11ad0077f 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -77,29 +77,35 @@ let unregister sr = ) ) +(* This function is entirely unused, but I am not sure if it should be + deleted or not *) let query_result_of_sr sr = - try with_lock m (fun () -> Some (Hashtbl.find plugins sr).query_result) - with _ -> None + with_lock m (fun () -> + Option.map (fun x -> x.query_result) (Hashtbl.find_opt plugins sr) + ) let sr_has_capability sr capability = - try - with_lock m (fun () -> - Smint.has_capability capability (Hashtbl.find plugins sr).features - ) - with _ -> false + with_lock m (fun () -> + match Hashtbl.find_opt plugins sr with + | Some x -> + Smint.has_capability capability x.features + | None -> + false + ) (* This is the policy: *) let of_sr sr = with_lock m (fun () -> - if not (Hashtbl.mem plugins sr) then ( - error "No storage plugin for SR: %s (currently-registered = [ %s ])" - (s_of_sr sr) - (String.concat ", " - (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) - ) ; - raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) - ) else - (Hashtbl.find plugins sr).processor + match Hashtbl.find_opt plugins sr with + | Some x -> + x.processor + | None -> + error "No storage plugin for SR: %s (currently-registered = [ %s ])" + (s_of_sr sr) + (String.concat ", " + (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) + ) ; + raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) ) type 'a sm_result = SMSuccess of 'a | SMFailure of exn @@ -848,11 +854,12 @@ module Mux = struct module Policy = struct let get_backend_vm () ~dbg:_ ~vm:_ ~sr ~vdi:_ = - if not (Hashtbl.mem plugins sr) then ( - error "No registered plugin for sr = %s" (s_of_sr sr) ; - raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) - ) else - (Hashtbl.find plugins sr).backend_domain + match Hashtbl.find_opt plugins sr with + | Some x -> + x.backend_domain + | None -> + error "No registered plugin for sr = %s" (s_of_sr sr) ; + raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) end module TASK = Storage_smapiv1_wrapper.Impl.TASK diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml index b6abfdcd2c3..465b5d354b1 100644 --- a/ocaml/xapi/storage_smapiv1.ml +++ b/ocaml/xapi/storage_smapiv1.ml @@ -590,10 +590,13 @@ module SMAPIv1 : Server_impl = struct try let read_write = with_lock vdi_read_write_m (fun () -> - if not (Hashtbl.mem vdi_read_write (sr, vdi)) then - error "VDI.activate: doesn't know if sr:%s vdi:%s is RO or RW" - (s_of_sr sr) (s_of_vdi vdi) ; - Hashtbl.find vdi_read_write (sr, vdi) + match Hashtbl.find_opt vdi_read_write (sr, vdi) with + | Some x -> + x + | None -> + error "VDI.activate: doesn't know if sr:%s vdi:%s is RO or RW" + (s_of_sr sr) (s_of_vdi vdi) ; + false ) in for_vdi ~dbg ~sr ~vdi "VDI.activate" (fun device_config _type sr self -> diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml index 8fde6ec60bd..04d0e99ecf8 100644 --- a/ocaml/xapi/storage_smapiv1_wrapper.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -250,10 +250,7 @@ module Sr = struct let m = Mutex.create () - let find vdi sr = - with_lock m (fun () -> - try Some (Hashtbl.find sr.vdis vdi) with Not_found -> None - ) + let find vdi sr = with_lock m (fun () -> Hashtbl.find_opt sr.vdis vdi) let add_or_replace vdi vdi_t sr = with_lock m (fun () -> Hashtbl.replace sr.vdis vdi vdi_t) @@ -289,10 +286,7 @@ module Host = struct let m = Mutex.create () - let find sr h = - with_lock m (fun () -> - try Some (Hashtbl.find h.srs sr) with Not_found -> None - ) + let find sr h = with_lock m (fun () -> Hashtbl.find_opt h.srs sr) let remove sr h = with_lock m (fun () -> Hashtbl.remove h.srs sr) @@ -388,12 +382,13 @@ functor let locks_find sr = let sr_key = s_of_sr sr in with_lock locks_m (fun () -> - if not (Hashtbl.mem locks sr_key) then ( - let result = Storage_locks.make () in - Hashtbl.replace locks sr_key result ; - result - ) else - Hashtbl.find locks sr_key + match Hashtbl.find_opt locks sr_key with + | Some x -> + x + | None -> + let result = Storage_locks.make () in + Hashtbl.replace locks sr_key result ; + result ) let locks_remove sr = diff --git a/ocaml/xapi/system_domains.ml b/ocaml/xapi/system_domains.ml index 2b2b5095c90..5fb394605b1 100644 --- a/ocaml/xapi/system_domains.ml +++ b/ocaml/xapi/system_domains.ml @@ -258,7 +258,7 @@ let unregister_service service = let get_service service = with_lock service_to_queue_m (fun () -> - try Some (Hashtbl.find service_to_queue service) with Not_found -> None + Hashtbl.find_opt service_to_queue service ) let list_services () = diff --git a/ocaml/xapi/xapi_dr.ml b/ocaml/xapi/xapi_dr.ml index b2f80481324..dfe563ec204 100644 --- a/ocaml/xapi/xapi_dr.ml +++ b/ocaml/xapi/xapi_dr.ml @@ -150,12 +150,7 @@ let remove_vdis_from_cache ~__context ~vdis = ) let read_vdi_cache_record ~vdi = - with_lock db_vdi_cache_mutex (fun () -> - if Hashtbl.mem db_vdi_cache vdi then - Some (Hashtbl.find db_vdi_cache vdi) - else - None - ) + with_lock db_vdi_cache_mutex (fun () -> Hashtbl.find_opt db_vdi_cache vdi) let handle_metadata_vdis ~__context ~sr = let sr_uuid = Db.SR.get_uuid ~__context ~self:sr in diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index 4c6a5eac959..b56e4199779 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -224,21 +224,22 @@ module Next = struct one if one doesn't exist already *) let get_subscription session = with_lock m (fun () -> - if Hashtbl.mem subscriptions session then - Hashtbl.find subscriptions session - else - let subscription = - { - last_id= !id - ; subs= [] - ; m= Mutex.create () - ; session - ; session_invalid= false - ; timeout= 0.0 - } - in - Hashtbl.replace subscriptions session subscription ; - subscription + match Hashtbl.find_opt subscriptions session with + | Some x -> + x + | None -> + let subscription = + { + last_id= !id + ; subs= [] + ; m= Mutex.create () + ; session + ; session_invalid= false + ; timeout= 0.0 + } + in + Hashtbl.replace subscriptions session subscription ; + subscription ) let on_session_deleted session_id = @@ -248,11 +249,12 @@ module Next = struct with_lock sub.m (fun () -> sub.session_invalid <- true) ; Condition.broadcast c in - if Hashtbl.mem subscriptions session_id then ( - let sub = Hashtbl.find subscriptions session_id in - mark_invalid sub ; - Hashtbl.remove subscriptions session_id - ) + Option.iter + (fun sub -> + mark_invalid sub ; + Hashtbl.remove subscriptions session_id + ) + (Hashtbl.find_opt subscriptions session_id) ) let session_is_invalid sub = with_lock sub.m (fun () -> sub.session_invalid) @@ -381,10 +383,7 @@ module From = struct in with_lock m (fun () -> let existing = - if Hashtbl.mem calls session then - Hashtbl.find calls session - else - [] + Option.value (Hashtbl.find_opt calls session) ~default:[] in Hashtbl.replace calls session (fresh :: existing) ) ; @@ -392,15 +391,17 @@ module From = struct (fun () -> f fresh) (fun () -> with_lock m (fun () -> - if Hashtbl.mem calls session then - let existing = Hashtbl.find calls session in - let remaining = - List.filter (fun x -> not (x.index = fresh.index)) existing - in - if remaining = [] then - Hashtbl.remove calls session - else - Hashtbl.replace calls session remaining + Option.iter + (fun existing -> + let remaining = + List.filter (fun x -> not (x.index = fresh.index)) existing + in + if remaining = [] then + Hashtbl.remove calls session + else + Hashtbl.replace calls session remaining + ) + (Hashtbl.find_opt calls session) ) ) @@ -412,10 +413,12 @@ module From = struct with_lock sub.m (fun () -> sub.session_invalid <- true) ; Condition.broadcast c in - if Hashtbl.mem calls session_id then ( - List.iter mark_invalid (Hashtbl.find calls session_id) ; - Hashtbl.remove calls session_id - ) + Option.iter + (fun x -> + List.iter mark_invalid x ; + Hashtbl.remove calls session_id + ) + (Hashtbl.find_opt calls session_id) ) let session_is_invalid call = with_lock call.m (fun () -> call.session_invalid) diff --git a/ocaml/xapi/xapi_guest_agent.ml b/ocaml/xapi/xapi_guest_agent.ml index 1de7d904748..ffe5b8ae618 100644 --- a/ocaml/xapi/xapi_guest_agent.ml +++ b/ocaml/xapi/xapi_guest_agent.ml @@ -354,30 +354,32 @@ let all (lookup : string -> string option) (list : string -> string list) let self = Db.VM.get_by_uuid ~__context ~uuid in let guest_metrics_cached = with_lock mutex (fun () -> - try Hashtbl.find cache domid - with _ -> - (* Make sure our cached idea of whether the domain is live or not is correct *) - let vm_guest_metrics = Db.VM.get_guest_metrics ~__context ~self in - let live = - true - && Db.is_valid_ref __context vm_guest_metrics - && Db.VM_guest_metrics.get_live ~__context ~self:vm_guest_metrics - in - if live then - dead_domains := IntSet.remove domid !dead_domains - else - dead_domains := IntSet.add domid !dead_domains ; - { - pv_drivers_version= [] - ; os_version= [] - ; networks= [] - ; other= [] - ; memory= [] - ; device_id= [] - ; last_updated= 0.0 - ; can_use_hotplug_vbd= `unspecified - ; can_use_hotplug_vif= `unspecified - } + match Hashtbl.find_opt cache domid with + | Some x -> + x + | None -> + (* Make sure our cached idea of whether the domain is live or not is correct *) + let vm_guest_metrics = Db.VM.get_guest_metrics ~__context ~self in + let live = + true + && Db.is_valid_ref __context vm_guest_metrics + && Db.VM_guest_metrics.get_live ~__context ~self:vm_guest_metrics + in + if live then + dead_domains := IntSet.remove domid !dead_domains + else + dead_domains := IntSet.add domid !dead_domains ; + { + pv_drivers_version= [] + ; os_version= [] + ; networks= [] + ; other= [] + ; memory= [] + ; device_id= [] + ; last_updated= 0.0 + ; can_use_hotplug_vbd= `unspecified + ; can_use_hotplug_vif= `unspecified + } ) in (* Only if the data is valid, cache it (CA-20353) *) diff --git a/ocaml/xapi/xapi_ha_vm_failover.ml b/ocaml/xapi/xapi_ha_vm_failover.ml index 4aa9ee17128..c834e384251 100644 --- a/ocaml/xapi/xapi_ha_vm_failover.ml +++ b/ocaml/xapi/xapi_ha_vm_failover.ml @@ -1423,10 +1423,11 @@ let restart_auto_run_vms ~__context live_set n = ) ; (* If we tried before and failed, don't retry again within 2 minutes *) let attempt_restart = - if Hashtbl.mem last_start_attempt vm then - Unix.gettimeofday () -. Hashtbl.find last_start_attempt vm > 120. - else - true + match Hashtbl.find_opt last_start_attempt vm with + | Some x -> + Unix.gettimeofday () -. x > 120. + | None -> + true in if attempt_restart then ( Hashtbl.replace last_start_attempt vm (Unix.gettimeofday ()) ; diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index dcac8edc5ce..beb3f2d13b0 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -152,21 +152,22 @@ let valid_operations ~__context record _ref' = table let throw_error table op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_host_helpers.assert_operation_valid unknown operation: %s" - (host_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_host_helpers.assert_operation_valid unknown operation: \ + %s" + (host_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.host_allowed_operations) diff --git a/ocaml/xapi/xapi_pci_helpers.ml b/ocaml/xapi/xapi_pci_helpers.ml index 873031c9f35..4e7009e2bdb 100644 --- a/ocaml/xapi/xapi_pci_helpers.ml +++ b/ocaml/xapi/xapi_pci_helpers.ml @@ -75,10 +75,12 @@ end = struct let make () = Hashtbl.create 100 let is_virtual t addr = - try Hashtbl.find t addr - with Not_found -> - let v = is_virtual addr in - Hashtbl.replace t addr v ; v + match Hashtbl.find_opt t addr with + | Some x -> + x + | None -> + let v = is_virtual addr in + Hashtbl.replace t addr v ; v end (** [is_related_to x y] is true, if two non-virtual PCI devices diff --git a/ocaml/xapi/xapi_pool_helpers.ml b/ocaml/xapi/xapi_pool_helpers.ml index d8c31f7071a..d023cce84d1 100644 --- a/ocaml/xapi/xapi_pool_helpers.ml +++ b/ocaml/xapi/xapi_pool_helpers.ml @@ -128,21 +128,22 @@ let valid_operations ~__context record (pool : API.ref_pool) = table let throw_error table op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_pool_helpers.assert_operation_valid unknown operation: %s" - (pool_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_pool_helpers.assert_operation_valid unknown operation: \ + %s" + (pool_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.pool_allowed_operations) diff --git a/ocaml/xapi/xapi_pool_update.ml b/ocaml/xapi/xapi_pool_update.ml index 1a9b8544bad..84ebbe6e23c 100644 --- a/ocaml/xapi/xapi_pool_update.ml +++ b/ocaml/xapi/xapi_pool_update.ml @@ -125,7 +125,9 @@ let with_dec_refcount ~__context ~uuid ~vdi f = with_lock updates_to_attach_count_tbl_mutex (fun () -> assert_update_vbds_attached ~__context ~vdi ; let count = - try Hashtbl.find updates_to_attach_count_tbl uuid with _ -> 0 + Option.value + (Hashtbl.find_opt updates_to_attach_count_tbl uuid) + ~default:0 in debug "pool_update.detach_helper '%s' count=%d" uuid count ; if count <= 1 then @@ -139,7 +141,9 @@ let with_dec_refcount ~__context ~uuid ~vdi f = let with_inc_refcount ~__context ~uuid ~vdi f = with_lock updates_to_attach_count_tbl_mutex (fun () -> let count = - try Hashtbl.find updates_to_attach_count_tbl uuid with _ -> 0 + Option.value + (Hashtbl.find_opt updates_to_attach_count_tbl uuid) + ~default:0 in debug "pool_update.attach_helper refcount='%d'" count ; if count = 0 then diff --git a/ocaml/xapi/xapi_role.ml b/ocaml/xapi/xapi_role.ml index f63f13caa74..c26ca678f81 100644 --- a/ocaml/xapi/xapi_role.ml +++ b/ocaml/xapi/xapi_role.ml @@ -47,12 +47,12 @@ let _ = (fun r -> Hashtbl.add static_role_by_name_label_tbl r.role_name_label r) get_all_static_roles -let find_role_by_ref ref = Hashtbl.find static_role_by_ref_tbl ref +let find_role_by_ref ref = Hashtbl.find_opt static_role_by_ref_tbl ref -let find_role_by_uuid uuid = Hashtbl.find static_role_by_uuid_tbl uuid +let find_role_by_uuid uuid = Hashtbl.find_opt static_role_by_uuid_tbl uuid let find_role_by_name_label name_label = - Hashtbl.find static_role_by_name_label_tbl name_label + Hashtbl.find_opt static_role_by_name_label_tbl name_label (* val get_all : __context:Context.t -> ref_role_set*) let get_all ~__context = @@ -64,13 +64,13 @@ let get_all ~__context = let is_valid_role ~__context ~role = Hashtbl.mem static_role_by_ref_tbl role let get_common ~__context ~self ~static_fn ~db_fn = - try - (* first look up across the static roles *) - let static_record = find_role_by_ref self in - static_fn static_record - with Not_found -> - (* then look up across the roles in the Db *) - db_fn ~__context ~self + match find_role_by_ref self with + (* first look up across the static roles *) + | Some static_record -> + static_fn static_record + | None -> + (* then look up across the roles in the Db *) + db_fn ~__context ~self (* val get_record : __context:Context.t -> self:ref_role -> role_t*) let get_api_record ~static_record = @@ -121,20 +121,20 @@ let get_all_records ~__context = get_all_records_where ~__context ~expr:"True" (* val get_by_uuid : __context:Context.t -> uuid:string -> ref_role*) let get_by_uuid ~__context ~uuid = - try - let static_record = find_role_by_uuid uuid in - ref_of_role ~role:static_record - with Not_found -> - (* pass-through to Db *) - Db.Role.get_by_uuid ~__context ~uuid + match find_role_by_uuid uuid with + | Some static_record -> + ref_of_role ~role:static_record + | None -> + (* pass-through to Db *) + Db.Role.get_by_uuid ~__context ~uuid let get_by_name_label ~__context ~label = - try - let static_record = find_role_by_name_label label in - [ref_of_role ~role:static_record] - with Not_found -> - (* pass-through to Db *) - Db.Role.get_by_name_label ~__context ~label + match find_role_by_name_label label with + | Some static_record -> + [ref_of_role ~role:static_record] + | None -> + (* pass-through to Db *) + Db.Role.get_by_name_label ~__context ~label (* val get_uuid : __context:Context.t -> self:ref_role -> string*) let get_uuid ~__context ~self = diff --git a/ocaml/xapi/xapi_sr_operations.ml b/ocaml/xapi/xapi_sr_operations.ml index 5d4cc834750..6199507d87c 100644 --- a/ocaml/xapi/xapi_sr_operations.ml +++ b/ocaml/xapi/xapi_sr_operations.ml @@ -98,6 +98,9 @@ let valid_operations ~__context ?op record _ref' : table = (ops : API.storage_operations_set) = List.iter (fun op -> + (* Exception can't be raised since the hash table is + pre-filled for all_ops, and set_errors is applied + to a subset of all_ops (disallowed_during_rpu) *) if Hashtbl.find table op = None then Hashtbl.replace table op (Some (code, params)) ) @@ -221,21 +224,21 @@ let valid_operations ~__context ?op record _ref' : table = table let throw_error (table : table) op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_sr.assert_operation_valid unknown operation: %s" - (sr_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_sr.assert_operation_valid unknown operation: %s" + (sr_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.storage_operations) = diff --git a/ocaml/xapi/xapi_vbd_helpers.ml b/ocaml/xapi/xapi_vbd_helpers.ml index a24a9fb5106..6226b26c34e 100644 --- a/ocaml/xapi/xapi_vbd_helpers.ml +++ b/ocaml/xapi/xapi_vbd_helpers.ml @@ -60,6 +60,9 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = (ops : API.vbd_operations_set) = List.iter (fun op -> + (* Exception can't be raised since the hash table is + pre-filled for all_ops, and set_errors is applied + to a subset of all_ops *) if Hashtbl.find table op = None then Hashtbl.replace table op (Some (code, params)) ) @@ -296,21 +299,21 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = table let throw_error (table : table) op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_vbd_helpers.assert_operation_valid unknown operation: %s" - (vbd_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_vbd_helpers.assert_operation_valid unknown operation: %s" + (vbd_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.vbd_operations) = diff --git a/ocaml/xapi/xapi_vdi_helpers.ml b/ocaml/xapi/xapi_vdi_helpers.ml index 0fe39c68c26..15b00211d73 100644 --- a/ocaml/xapi/xapi_vdi_helpers.ml +++ b/ocaml/xapi/xapi_vdi_helpers.ml @@ -151,25 +151,25 @@ let disable_database_replication ~__context ~vdi = debug "Attempting to disable metadata replication on VDI [%s:%s]." (Db.VDI.get_name_label ~__context ~self:vdi) (Db.VDI.get_uuid ~__context ~self:vdi) ; - if not (Hashtbl.mem metadata_replication vdi) then - debug "Metadata is not being replicated to this VDI." - else - let vbd, log = Hashtbl.find metadata_replication vdi in - Redo_log.shutdown log ; - Redo_log.disable log ; - (* Check the recorded VBD still exists before trying to unplug and destroy it. *) - if Db.is_valid_ref __context vbd then - Helpers.call_api_functions ~__context (fun rpc session_id -> - try - Attach_helpers.safe_unplug rpc session_id vbd ; - Client.VBD.destroy ~rpc ~session_id ~self:vbd - with e -> - debug "Caught %s while trying to dispose of VBD %s." - (Printexc.to_string e) (Ref.string_of vbd) - ) ; - Hashtbl.remove metadata_replication vdi ; - Redo_log.delete log ; - Db.VDI.set_metadata_latest ~__context ~self:vdi ~value:false + match Hashtbl.find_opt metadata_replication vdi with + | None -> + debug "Metadata is not being replicated to this VDI." + | Some (vbd, log) -> + Redo_log.shutdown log ; + Redo_log.disable log ; + (* Check the recorded VBD still exists before trying to unplug and destroy it. *) + if Db.is_valid_ref __context vbd then + Helpers.call_api_functions ~__context (fun rpc session_id -> + try + Attach_helpers.safe_unplug rpc session_id vbd ; + Client.VBD.destroy ~rpc ~session_id ~self:vbd + with e -> + debug "Caught %s while trying to dispose of VBD %s." + (Printexc.to_string e) (Ref.string_of vbd) + ) ; + Hashtbl.remove metadata_replication vdi ; + Redo_log.delete log ; + Db.VDI.set_metadata_latest ~__context ~self:vdi ~value:false ) let database_open_mutex = Mutex.create () diff --git a/ocaml/xapi/xapi_vif_helpers.ml b/ocaml/xapi/xapi_vif_helpers.ml index 751f987a6da..5b1f1f458f5 100644 --- a/ocaml/xapi/xapi_vif_helpers.ml +++ b/ocaml/xapi/xapi_vif_helpers.ml @@ -155,21 +155,21 @@ let valid_operations ~__context record _ref' : table = table let throw_error (table : table) op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_vif_helpers.assert_operation_valid unknown operation: %s" - (vif_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_vif_helpers.assert_operation_valid unknown operation: %s" + (vif_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.vif_operations) = diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 8a03aba27e1..8819d393170 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1117,11 +1117,11 @@ let record_call_plugin_latest vm = List.iter (Hashtbl.remove call_plugin_latest) !to_gc ; (* Then calculate the schedule *) let to_wait = - if Hashtbl.mem call_plugin_latest vm then - let t = Hashtbl.find call_plugin_latest vm in - Int64.sub (Int64.add t interval) now - else - 0L + match Hashtbl.find_opt call_plugin_latest vm with + | Some t -> + Int64.sub (Int64.add t interval) now + | None -> + 0L in if to_wait > 0L then raise diff --git a/ocaml/xapi/xapi_vusb_helpers.ml b/ocaml/xapi/xapi_vusb_helpers.ml index 09de9f80731..4c8b8d5eb2a 100644 --- a/ocaml/xapi/xapi_vusb_helpers.ml +++ b/ocaml/xapi/xapi_vusb_helpers.ml @@ -92,21 +92,22 @@ let valid_operations ~__context record _ref' : table = table let throw_error (table : table) op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_vusb_helpers.assert_operation_valid unknown operation: %s" - (vusb_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_vusb_helpers.assert_operation_valid unknown operation: \ + %s" + (vusb_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let update_allowed_operations ~__context ~self : unit = diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index a186b2e8b76..a6e29efa870 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -1812,12 +1812,12 @@ module Events_from_xenopsd = struct Client.UPDATES.remove_barrier dbg id ; let t = with_lock active_m @@ fun () -> - if not (Hashtbl.mem active id) then ( - warn "Events_from_xenopsd.wakeup: unknown id %d" id ; - None - ) else - let t = Hashtbl.find active id in - Hashtbl.remove active id ; Some t + match Hashtbl.find_opt active id with + | Some t -> + Hashtbl.remove active id ; Some t + | None -> + warn "Events_from_xenopsd.wakeup: unknown id %d" id ; + None in Option.iter (fun t -> diff --git a/ocaml/xapi/xha_interface.ml b/ocaml/xapi/xha_interface.ml index 979ef9288e3..608ae9a64a2 100644 --- a/ocaml/xapi/xha_interface.ml +++ b/ocaml/xapi/xha_interface.ml @@ -276,10 +276,12 @@ module LiveSetInformation = struct | Xml.Element ("host", _, children) -> let table = hash_table_of_leaf_xml_element_list children in let find x = - try Hashtbl.find table x - with Not_found -> - invalid_arg - (Printf.sprintf "Missig entry '%s' within 'host' element" x) + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + invalid_arg + (Printf.sprintf "Missig entry '%s' within 'host' element" x) in let bool s = try bool_of_string (String.lowercase_ascii s) @@ -326,12 +328,14 @@ module LiveSetInformation = struct | Xml.Element ("host_raw_data", _, children) -> let table = hash_table_of_leaf_xml_element_list children in let find x = - try Hashtbl.find table x - with Not_found -> - invalid_arg - (Printf.sprintf - "Missing entry '%s' within 'host_raw_data' element" x - ) + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + invalid_arg + (Printf.sprintf + "Missing entry '%s' within 'host_raw_data' element" x + ) in let int s = try int_of_string (String.lowercase_ascii s) @@ -382,12 +386,15 @@ module LiveSetInformation = struct | Xml.Element ("warning_on_local_host", _, children) -> let table = hash_table_of_leaf_xml_element_list children in let find x = - try Hashtbl.find table x - with Not_found -> - invalid_arg - (Printf.sprintf - "Missing entry '%s' within 'warning_on_local_host' element" x - ) + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + invalid_arg + (Printf.sprintf + "Missing entry '%s' within 'warning_on_local_host' element" + x + ) in let bool x = find x = "TRUE" in Some @@ -423,14 +430,16 @@ module LiveSetInformation = struct | Xml.Element ("raw_status_on_local_host", _, children) -> let table = hash_table_of_leaf_xml_element_list children in let find x = - try Hashtbl.find table x - with Not_found -> - invalid_arg - (Printf.sprintf - "Missing entry '%s' within 'raw_status_on_local_host' \ - element" - x - ) + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + invalid_arg + (Printf.sprintf + "Missing entry '%s' within 'raw_status_on_local_host' \ + element" + x + ) in let int s = try int_of_string (String.lowercase_ascii s) diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml index 9265084e020..4cf580ed590 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml @@ -96,8 +96,11 @@ let get_sr_rrd_handler (req : Http.Request.t) (s : Unix.file_descr) _ = let rrd = with_lock mutex (fun () -> let rrdi = - try Hashtbl.find sr_rrds sr_uuid - with Not_found -> failwith "No SR RRD available!" + match Hashtbl.find_opt sr_rrds sr_uuid with + | Some x -> + x + | None -> + failwith "No SR RRD available!" in Rrd.copy_rrd rrdi.rrd ) diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml index cb356f5bee4..f6a9fa43646 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml @@ -138,31 +138,31 @@ let update_rrds timestamp dss uuid_domids paused_vms = in let dss = StringMap.to_seq dss |> Seq.map snd |> List.of_seq in - try - let domid = StringMap.find vm_uuid uuid_domids in + match StringMap.find_opt vm_uuid uuid_domids with + | Some domid -> ( (* First, potentially update the rrd with any new default dss *) - try - let rrdi = Hashtbl.find vm_rrds vm_uuid in - let rrd = merge_new_dss rrdi.rrd dss in - Hashtbl.replace vm_rrds vm_uuid {rrd; dss; domid} ; - (* CA-34383: Memory updates from paused domains serve no useful - purpose. During a migrate such updates can also cause undesirable - discontinuities in the observed value of memory_actual. Hence, we - ignore changes from paused domains: *) - if not (StringSet.mem vm_uuid paused_vms) then ( - Rrd.ds_update_named rrd timestamp ~new_domid:(domid <> rrdi.domid) - named_updates ; - rrdi.dss <- dss ; - rrdi.domid <- domid - ) - with - | Not_found -> + match Hashtbl.find_opt vm_rrds vm_uuid with + | Some rrdi -> + let rrd = merge_new_dss rrdi.rrd dss in + Hashtbl.replace vm_rrds vm_uuid {rrd; dss; domid} ; + (* CA-34383: Memory updates from paused domains serve no useful + purpose. During a migrate such updates can also cause undesirable + discontinuities in the observed value of memory_actual. Hence, we + ignore changes from paused domains: *) + if not (StringSet.mem vm_uuid paused_vms) then ( + Rrd.ds_update_named rrd timestamp + ~new_domid:(domid <> rrdi.domid) named_updates ; + rrdi.dss <- dss ; + rrdi.domid <- domid + ) + | None -> debug "%s: Creating fresh RRD for VM uuid=%s" __FUNCTION__ vm_uuid ; let rrd = create_fresh_rrd !use_min_max dss in Hashtbl.replace vm_rrds vm_uuid {rrd; dss; domid} - | e -> - raise e - with _ -> log_backtrace () + ) + | None -> + info "%s: VM uuid=%s is not resident in this host, ignoring rrds" + __FUNCTION__ vm_uuid in let process_sr sr_uuid dss = let named_updates = @@ -171,20 +171,17 @@ let update_rrds timestamp dss uuid_domids paused_vms = let dss = StringMap.to_seq dss |> Seq.map snd |> List.of_seq in try (* First, potentially update the rrd with any new default dss *) - try - let rrdi = Hashtbl.find sr_rrds sr_uuid in - let rrd = merge_new_dss rrdi.rrd dss in - Hashtbl.replace sr_rrds sr_uuid {rrd; dss; domid= 0} ; - Rrd.ds_update_named rrd timestamp ~new_domid:false named_updates ; - rrdi.dss <- dss ; - rrdi.domid <- 0 - with - | Not_found -> + match Hashtbl.find_opt sr_rrds sr_uuid with + | Some rrdi -> + let rrd = merge_new_dss rrdi.rrd dss in + Hashtbl.replace sr_rrds sr_uuid {rrd; dss; domid= 0} ; + Rrd.ds_update_named rrd timestamp ~new_domid:false named_updates ; + rrdi.dss <- dss ; + rrdi.domid <- 0 + | None -> debug "%s: Creating fresh RRD for SR uuid=%s" __FUNCTION__ sr_uuid ; let rrd = create_fresh_rrd !use_min_max dss in Hashtbl.replace sr_rrds sr_uuid {rrd; dss; domid= 0} - | e -> - raise e with _ -> log_backtrace () in let process_host dss = diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml index e7556381c8e..f3f56003dad 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml @@ -24,13 +24,13 @@ open D let archive_sr_rrd (sr_uuid : string) : string = let sr_rrd = with_lock mutex (fun () -> - try - let rrd = Hashtbl.find sr_rrds sr_uuid in - Hashtbl.remove sr_rrds sr_uuid ; - rrd - with Not_found -> - let msg = Printf.sprintf "No RRD found for SR: %s." sr_uuid in - raise (Rrdd_error (Archive_failed msg)) + match Hashtbl.find_opt sr_rrds sr_uuid with + | Some rrd -> + Hashtbl.remove sr_rrds sr_uuid ; + rrd + | None -> + let msg = Printf.sprintf "No RRD found for SR: %s." sr_uuid in + raise (Rrdd_error (Archive_failed msg)) ) in try @@ -85,11 +85,13 @@ let archive_rrd vm_uuid (remote_address : string option) : unit = remote_address in with_lock mutex (fun () -> - try - let rrd = (Hashtbl.find vm_rrds vm_uuid).rrd in - Hashtbl.remove vm_rrds vm_uuid ; - archive_rrd_internal ~transport ~uuid:vm_uuid ~rrd () - with Not_found -> () + match Hashtbl.find_opt vm_rrds vm_uuid with + | Some x -> + let rrd = x.rrd in + Hashtbl.remove vm_rrds vm_uuid ; + archive_rrd_internal ~transport ~uuid:vm_uuid ~rrd () + | None -> + () ) (** This functionality is used by xapi to backup rrds to local disk or to the @@ -294,29 +296,27 @@ let remove_rrd (uuid : string) : unit = is assumed to be valid, since it is set by monitor_master. *) let migrate_rrd (session_id : string option) (remote_address : string) (vm_uuid : string) (host_uuid : string) : unit = - try - let rrdi = - with_lock mutex (fun () -> - let rrdi = Hashtbl.find vm_rrds vm_uuid in + with_lock mutex (fun () -> + match Hashtbl.find_opt vm_rrds vm_uuid with + | Some x -> debug "Sending RRD for VM uuid=%s to remote host %s for migrate" vm_uuid host_uuid ; Hashtbl.remove vm_rrds vm_uuid ; - rrdi - ) - in - let transport = - Xmlrpc_client.( - SSL (SSL.make ~verify_cert:None (), remote_address, !https_port) - ) - in - send_rrd ?session_id ~transport ~to_archive:false ~uuid:vm_uuid - ~rrd:rrdi.rrd () - with - | Not_found -> - debug "VM %s RRDs not found on migrate! Continuing anyway..." vm_uuid ; - log_backtrace () - | _ -> - log_backtrace () + Some x + | None -> + debug "VM %s RRDs not found on migrate! Continuing anyway..." vm_uuid ; + log_backtrace () ; + None + ) + |> Option.iter (fun rrdi -> + let transport = + Xmlrpc_client.( + SSL (SSL.make ~verify_cert:None (), remote_address, !https_port) + ) + in + send_rrd ?session_id ~transport ~to_archive:false ~uuid:vm_uuid + ~rrd:rrdi.rrd () + ) (* Called on host shutdown/reboot to send the Host RRD to the master for backup. Note all VMs will have been shutdown by now. *) @@ -756,11 +756,12 @@ module Plugin = struct process its output at most once more. *) let deregister (uid : P.uid) : unit = with_lock registered_m (fun _ -> - if Hashtbl.mem registered uid then ( - let plugin = Hashtbl.find registered uid in - plugin.reader.Rrd_reader.cleanup () ; - Hashtbl.remove registered uid - ) + Option.iter + (fun plugin -> + plugin.reader.Rrd_reader.cleanup () ; + Hashtbl.remove registered uid + ) + (Hashtbl.find_opt registered uid) ) (* Read, parse, and combine metrics from all registered plugins. *) diff --git a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml index 80691b0ab9d..dbfbd8cb73b 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml @@ -619,11 +619,9 @@ let dss_mem_vms doms = ) in let memory_target_opt = - try - with_lock Rrdd_shared.memory_targets_m (fun _ -> - Some (Hashtbl.find Rrdd_shared.memory_targets domid) - ) - with Not_found -> None + with_lock Rrdd_shared.memory_targets_m (fun _ -> + Hashtbl.find_opt Rrdd_shared.memory_targets domid + ) in let mem_target_ds = Option.map diff --git a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml index c718a033d0f..b8c60edec7e 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml +++ b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml @@ -192,11 +192,9 @@ module Iostat = struct (* Now read the values out of dev_values_map for devices for which we have data *) List.filter_map (fun dev -> - if not (Hashtbl.mem dev_values_map dev) then - None - else - let values = Hashtbl.find dev_values_map dev in - Some (dev, values) + Option.map + (fun values -> (dev, values)) + (Hashtbl.find_opt dev_values_map dev) ) devs end @@ -371,13 +369,13 @@ let exec_tap_ctl_list () : ((string * string) * int) list = (* Look up SR and VDI uuids from the physical path *) if not (Hashtbl.mem phypath_to_sr_vdi phypath) then refresh_phypath_to_sr_vdi () ; - if not (Hashtbl.mem phypath_to_sr_vdi phypath) then ( - (* Odd: tap-ctl mentions a device that's not linked from /dev/sm/phy *) - D.error "Could not find device with physical path %s" phypath ; - None - ) else - let sr, vdi = Hashtbl.find phypath_to_sr_vdi phypath in - Some (pid, (minor, (sr, vdi))) + match Hashtbl.find_opt phypath_to_sr_vdi phypath with + | Some (sr, vdi) -> + Some (pid, (minor, (sr, vdi))) + | None -> + (* Odd: tap-ctl mentions a device that's not linked from /dev/sm/phy *) + D.error "Could not find device with physical path %s" phypath ; + None in let process_line str = try Scanf.sscanf str "pid=%d minor=%d state=%s args=%s@:%s" extract_vdis diff --git a/ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml b/ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml index 6c2c11192fb..17b55481410 100644 --- a/ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml +++ b/ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml @@ -50,8 +50,9 @@ let signal_name signum = List.iter (fun (str, key) -> Hashtbl.add t key str) map ; t in - try Hashtbl.find signals signum - with Not_found -> Printf.sprintf "unknown signal (%d)" signum + Option.value + (Hashtbl.find_opt signals signum) + ~default:(Printf.sprintf "unknown signal (%d)" signum) module Utils = Utils diff --git a/ocaml/xcp-rrdd/lib/rrdd/stats.ml b/ocaml/xcp-rrdd/lib/rrdd/stats.ml index b85a9181c7a..c1996dd4e49 100644 --- a/ocaml/xcp-rrdd/lib/rrdd/stats.ml +++ b/ocaml/xcp-rrdd/lib/rrdd/stats.ml @@ -74,10 +74,9 @@ let sample (name : string) (x : float) : unit = let x' = log x in with_lock timings_m (fun () -> let p = - if Hashtbl.mem timings name then - Hashtbl.find timings name - else - Normal_population.empty + Option.value + (Hashtbl.find_opt timings name) + ~default:Normal_population.empty in let p' = Normal_population.sample p x' in Hashtbl.replace timings name p' @@ -143,17 +142,19 @@ let log_db_call task_opt dbcall ty = dbstats_drop_dbcalls in Hashtbl.replace hashtbl dbcall - (1 + try Hashtbl.find hashtbl dbcall with _ -> 0) ; + (1 + Option.value (Hashtbl.find_opt hashtbl dbcall) ~default:0) ; let threadid = Thread.id (Thread.self ()) in Hashtbl.replace dbstats_threads threadid ((dbcall, ty) - :: (try Hashtbl.find dbstats_threads threadid with _ -> []) + :: Option.value + (Hashtbl.find_opt dbstats_threads threadid) + ~default:[] ) ; match task_opt with | Some task -> Hashtbl.replace dbstats_task task ((dbcall, ty) - :: (try Hashtbl.find dbstats_task task with _ -> []) + :: Option.value (Hashtbl.find_opt dbstats_task task) ~default:[] ) | None -> () diff --git a/ocaml/xenopsd/list_domains/list_domains.ml b/ocaml/xenopsd/list_domains/list_domains.ml index 22d18543310..2a4ae05b2ca 100644 --- a/ocaml/xenopsd/list_domains/list_domains.ml +++ b/ocaml/xenopsd/list_domains/list_domains.ml @@ -99,9 +99,11 @@ let hashtbl_of_domaininfo x : (string, string) Hashtbl.t = let select table keys = List.map (fun key -> - if not (Hashtbl.mem table key) then - failwith (Printf.sprintf "Failed to find key: %s" key) ; - Hashtbl.find table key + match Hashtbl.find_opt table key with + | Some x -> + x + | None -> + failwith (Printf.sprintf "Failed to find key: %s" key) ) keys diff --git a/ocaml/xenopsd/xc/device.ml b/ocaml/xenopsd/xc/device.ml index 6d47a2489ef..20f2405a7e7 100644 --- a/ocaml/xenopsd/xc/device.ml +++ b/ocaml/xenopsd/xc/device.ml @@ -2786,10 +2786,9 @@ module Backend = struct Hashtbl.remove ftod (Qmp_protocol.to_fd c) ; Hashtbl.remove dtoc domid - let domid_of fd = try Some (Hashtbl.find ftod fd) with Not_found -> None + let domid_of fd = Hashtbl.find_opt ftod fd - let channel_of domid = - try Some (Hashtbl.find dtoc domid) with Not_found -> None + let channel_of domid = Hashtbl.find_opt dtoc domid end (** File-descriptor event monitor implementation for the epoll library *) diff --git a/ocaml/xenopsd/xc/readln.ml b/ocaml/xenopsd/xc/readln.ml index 9ee995723db..bbd91fb6e47 100644 --- a/ocaml/xenopsd/xc/readln.ml +++ b/ocaml/xenopsd/xc/readln.ml @@ -11,7 +11,9 @@ let read fd = let buffer = Bytes.make buffer_size '\000' in match Unix.read fd buffer 0 buffer_size with | 0 -> - let pending = try Hashtbl.find input fd with Not_found -> Bytes.empty in + let pending = + Option.value (Hashtbl.find_opt input fd) ~default:Bytes.empty + in Hashtbl.remove input fd ; if pending = Bytes.empty then EOF diff --git a/ocaml/xenopsd/xc/stats.ml b/ocaml/xenopsd/xc/stats.ml index 4e25cdca45f..e551e81aaf9 100644 --- a/ocaml/xenopsd/xc/stats.ml +++ b/ocaml/xenopsd/xc/stats.ml @@ -76,10 +76,9 @@ let sample (name : string) (x : float) : unit = let x' = log x in with_lock timings_m (fun () -> let p = - if Hashtbl.mem timings name then - Hashtbl.find timings name - else - Normal_population.empty + Option.value + (Hashtbl.find_opt timings name) + ~default:Normal_population.empty in let p' = Normal_population.sample p x' in Hashtbl.replace timings name p' @@ -143,17 +142,19 @@ let log_db_call task_opt dbcall ty = dbstats_drop_dbcalls in Hashtbl.replace hashtbl dbcall - (1 + try Hashtbl.find hashtbl dbcall with _ -> 0) ; + (1 + Option.value (Hashtbl.find_opt hashtbl dbcall) ~default:0) ; let threadid = Thread.id (Thread.self ()) in Hashtbl.replace dbstats_threads threadid ((dbcall, ty) - :: (try Hashtbl.find dbstats_threads threadid with _ -> []) + :: Option.value + (Hashtbl.find_opt dbstats_threads threadid) + ~default:[] ) ; match task_opt with | Some task -> Hashtbl.replace dbstats_task task ((dbcall, ty) - :: (try Hashtbl.find dbstats_task task with _ -> []) + :: Option.value (Hashtbl.find_opt dbstats_task task) ~default:[] ) | None -> () diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index a3317194f24..44d4e4e942c 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -961,10 +961,7 @@ module HOST = struct get_lines () ; close_in in_chan ; let find key = - if Hashtbl.mem tbl key then - Hashtbl.find tbl key - else - "unknown" + Option.value (Hashtbl.find_opt tbl key) ~default:"unknown" in ( find "vendor_id" , find "model name" From 1869b443a0391f7af71296198eb2b9477d9423a2 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 26 Jun 2024 13:16:36 +0100 Subject: [PATCH 30/44] Refactor Hashtbl.find out of resources/table.ml Signed-off-by: Andrii Sultanov --- ocaml/libs/resources/table.ml | 2 +- ocaml/libs/stunnel/stunnel_cache.ml | 57 +++++++++++++++++++---------- 2 files changed, 38 insertions(+), 21 deletions(-) diff --git a/ocaml/libs/resources/table.ml b/ocaml/libs/resources/table.ml index 9c284f80de8..35aa88082ca 100644 --- a/ocaml/libs/resources/table.ml +++ b/ocaml/libs/resources/table.ml @@ -41,7 +41,7 @@ struct Hashtbl.remove t k ) - let find (t, m) k = with_lock m (fun () -> Hashtbl.find t k) + let find (t, m) k = with_lock m (fun () -> Hashtbl.find_opt t k) let with_find_moved_exn (t, m) k = let v = diff --git a/ocaml/libs/stunnel/stunnel_cache.ml b/ocaml/libs/stunnel/stunnel_cache.ml index 57f361d26ce..36d986b89c3 100644 --- a/ocaml/libs/stunnel/stunnel_cache.ml +++ b/ocaml/libs/stunnel/stunnel_cache.ml @@ -74,10 +74,13 @@ let unlocked_gc () = ( if debug_enabled then let now = Unix.gettimeofday () in let string_of_id id = - let stunnel = Tbl.find !stunnels id in - Printf.sprintf "(id %s / idle %.2f age %.2f)" (id_of_stunnel stunnel) - (now -. Hashtbl.find !times id) - (now -. stunnel.Stunnel.connected_time) + match (Tbl.find !stunnels id, Hashtbl.find_opt !times id) with + | Some stunnel, Some stunnel_id -> + Printf.sprintf "(id %s / idle %.2f age %.2f)" + (id_of_stunnel stunnel) (now -. stunnel_id) + (now -. stunnel.Stunnel.connected_time) + | _ -> + Printf.sprintf "%s: found no entry for id=%d" __FUNCTION__ id in let string_of_endpoint ep = Printf.sprintf "%s:%d" ep.host ep.port in let string_of_index ep xs = @@ -134,11 +137,15 @@ let unlocked_gc () = let oldest_ids = List.map fst oldest in List.iter (fun x -> - let stunnel = Tbl.find !stunnels x in - debug - "Expiring stunnel id %s since we have too many cached tunnels (limit \ - is %d)" - (id_of_stunnel stunnel) max_stunnel + match Tbl.find !stunnels x with + | Some stunnel -> + debug + "Expiring stunnel id %s since we have too many cached tunnels \ + (limit is %d)" + (id_of_stunnel stunnel) max_stunnel + | None -> + debug "%s: Couldn't find an expiring stunnel (id=%d) in the table" + __FUNCTION__ x ) oldest_ids ; to_gc := !to_gc @ oldest_ids @@ -146,8 +153,8 @@ let unlocked_gc () = (* Disconnect all stunnels we wish to GC *) List.iter (fun id -> - let s = Tbl.find !stunnels id in - Stunnel.disconnect s + (* Only remove stunnel if we find it in the table *) + Option.iter (fun s -> Stunnel.disconnect s) (Tbl.find !stunnels id) ) !to_gc ; (* Remove all reference to them from our cache hashtables *) @@ -201,23 +208,33 @@ let with_remove ~host ~port verified f = let get_id () = with_lock m (fun () -> unlocked_gc () ; - let ids = Hashtbl.find !index ep in - let table = List.map (fun id -> (id, Hashtbl.find !times id)) ids in + let ( let* ) = Option.bind in + let* ids = Hashtbl.find_opt !index ep in + let table = + List.filter_map + (fun id -> + Option.map (fun time -> (id, time)) (Hashtbl.find_opt !times id) + ) + ids + in let sorted = List.sort (fun a b -> compare (snd a) (snd b)) table in match sorted with | (id, time) :: _ -> - let stunnel = Tbl.find !stunnels id in - debug "Removing stunnel id %s (idle %.2f) from the cache" - (id_of_stunnel stunnel) - (Unix.gettimeofday () -. time) ; + Option.iter + (fun stunnel -> + debug "Removing stunnel id %s (idle %.2f) from the cache" + (id_of_stunnel stunnel) + (Unix.gettimeofday () -. time) + ) + (Tbl.find !stunnels id) ; Hashtbl.remove !times id ; Hashtbl.replace !index ep (List.filter (fun x -> x <> id) ids) ; - id + Some id | _ -> - raise Not_found + None ) in - let id_opt = try Some (get_id ()) with Not_found -> None in + let id_opt = get_id () in id_opt |> Option.map @@ fun id -> (* cannot call while holding above mutex or we deadlock *) From 47f3c3d68f839176007fb3168d169805d74d48c6 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 26 Jun 2024 13:17:10 +0100 Subject: [PATCH 31/44] Refactor Hashtbl.find out of xenopsd/xc/readln.ml Signed-off-by: Andrii Sultanov --- ocaml/xenopsd/xc/readln.ml | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/ocaml/xenopsd/xc/readln.ml b/ocaml/xenopsd/xc/readln.ml index bbd91fb6e47..928b289881c 100644 --- a/ocaml/xenopsd/xc/readln.ml +++ b/ocaml/xenopsd/xc/readln.ml @@ -23,25 +23,26 @@ let read fd = (Bytes.to_string pending) ) | n -> - let data = Bytes.sub buffer 0 n in - let inpt = try Hashtbl.find input fd with Not_found -> Bytes.empty in - Hashtbl.replace input fd (Bytes.cat inpt data) ; - let rec loop msgs = - let data = Hashtbl.find input fd in - (* never fails *) - match Bytes.index data '\n' with - | exception Not_found -> - Ok (List.rev msgs) - | index -> + let rec loop msgs data = + match Bytes.index_opt data '\n' with + | None -> + (List.rev msgs, data) + | Some index -> let remain = Bytes.sub data (index + 1) (Bytes.length data - index - 1) in - Hashtbl.replace input fd remain ; - (* reset input *) - loop (Bytes.sub_string data 0 index :: msgs) - (* store msg *) + loop + (Bytes.sub_string data 0 index :: msgs) + remain (* reset input *) + in + let data = Bytes.sub buffer 0 n in + let inpt = + Option.value (Hashtbl.find_opt input fd) ~default:Bytes.empty in - loop [] + let inp_data = Bytes.cat inpt data in + let res, data = loop [] inp_data in + Hashtbl.replace input fd data ; + Ok res | exception Unix.Unix_error (error, _, _) -> Error (Unix.error_message error) From d4be15e09702ab5be5bf68c7a2b786a0883b0758 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Thu, 27 Jun 2024 13:40:51 +0100 Subject: [PATCH 32/44] Add a gate for Hashbtl.find Signed-off-by: Andrii Sultanov --- quality-gate.sh | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/quality-gate.sh b/quality-gate.sh index f12113a215f..a3e443d007f 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -104,6 +104,19 @@ unixgetenv () { fi } +hashtblfind () { + N=36 + # Looks for all .ml files except the ones using Core.Hashtbl.find, + # which already returns Option + HASHTBLFIND=$(git grep -P -r --count 'Hashtbl.find(?!_opt)' -- '**/*.ml' ':!ocaml/xapi-storage-script/main.ml' | cut -d ':' -f 2 | paste -sd+ - | bc) + if [ "$HASHTBLFIND" -eq "$N" ]; then + echo "OK counted $HASHTBLFIND usages of exception-raising Hashtbl.find" + else + echo "ERROR expected $N usages of exception-raising Hashtbl.find, got $HASHTBLFIND" 1>&2 + exit 1 + fi +} + list-hd verify-cert mli-files @@ -112,4 +125,5 @@ vtpm-unimplemented vtpm-fields ocamlyacc unixgetenv +hashtblfind From e11436e75aa61bf6ee6fd9b3455c3ba6f3d24dce Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Fri, 5 Jul 2024 03:11:39 +0100 Subject: [PATCH 33/44] CP-50135: Bump datamodel_lifecycle for anti-affinity datamodel_lifecycle.ml needs to be bumped to 24.18.0-next for anti-affinity change. Signed-off-by: Bengang Yuan --- ocaml/idl/datamodel_lifecycle.ml | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index 5cb7324c9c3..92316d8ee26 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -1,4 +1,6 @@ let prototyped_of_class = function + | "VM_group" -> + Some "24.18.0-next" | "Observer" -> Some "23.14.0" | "VTPM" -> @@ -7,6 +9,10 @@ let prototyped_of_class = function None let prototyped_of_field = function + | "VM_group", "VMs" -> + Some "24.18.0-next" + | "VM_group", "placement" -> + Some "24.18.0-next" | "Observer", "enabled" -> Some "23.14.0" | "Observer", "components" -> @@ -55,6 +61,8 @@ let prototyped_of_field = function Some "22.27.0" | "host", "last_software_update" -> Some "22.20.0" + | "VM", "groups" -> + Some "24.18.0-next" | "VM", "pending_guidances_full" -> Some "24.10.0" | "VM", "pending_guidances_recommended" -> @@ -63,6 +71,8 @@ let prototyped_of_field = function Some "23.18.0" | "VM", "actions__after_softreboot" -> Some "23.1.0" + | "pool", "recommendations" -> + Some "24.18.0-next" | "pool", "update_sync_enabled" -> Some "23.18.0" | "pool", "update_sync_day" -> @@ -139,6 +149,8 @@ let prototyped_of_message = function Some "24.17.0" | "VM", "restart_device_models" -> Some "23.30.0" + | "VM", "set_groups" -> + Some "24.18.0-next" | "pool", "get_guest_secureboot_readiness" -> Some "24.17.0" | "pool", "set_ext_auth_max_threads" -> From 16b79a023e6d438b242e0e4dd245362f836bf79b Mon Sep 17 00:00:00 2001 From: Alex Brett Date: Tue, 18 Jun 2024 14:53:16 +0000 Subject: [PATCH 34/44] IH-621: Add IPMI host power on support and remove DRAC DRAC power on support relies upon a Dell supplemental pack which is no longer available, so remove it. Add IPMI power on support using ipmitool, which should work with virtually any modern server which has a BMC, regardless of vendor. Signed-off-by: Alex Brett --- ocaml/idl/datamodel_host.ml | 2 +- scripts/Makefile | 2 +- scripts/poweron/DRAC.py | 60 ------------------------------------- scripts/poweron/IPMI.py | 46 ++++++++++++++++++++++++++++ scripts/poweron/power-on.py | 10 +++---- 5 files changed, 53 insertions(+), 67 deletions(-) delete mode 100644 scripts/poweron/DRAC.py create mode 100644 scripts/poweron/IPMI.py diff --git a/ocaml/idl/datamodel_host.ml b/ocaml/idl/datamodel_host.ml index 2f9d1d7ed83..dad24eabf17 100644 --- a/ocaml/idl/datamodel_host.ml +++ b/ocaml/idl/datamodel_host.ml @@ -1375,7 +1375,7 @@ let set_power_on_mode = (Ref _host, "self", "The host") ; ( String , "power_on_mode" - , "power-on-mode can be empty, wake-on-lan, DRAC or other" + , "power-on-mode can be empty, wake-on-lan, IPMI or other" ) ; (Map (String, String), "power_on_config", "Power on config") ] diff --git a/scripts/Makefile b/scripts/Makefile index 020cbbeff49..18e923c69fa 100644 --- a/scripts/Makefile +++ b/scripts/Makefile @@ -178,7 +178,7 @@ endif # poweron $(IPROG) poweron/wlan.py $(DESTDIR)$(PLUGINDIR)/wlan.py $(IPROG) poweron/wlan.py $(DESTDIR)$(PLUGINDIR)/wake-on-lan - $(IPROG) poweron/DRAC.py $(DESTDIR)$(PLUGINDIR)/DRAC.py + $(IPROG) poweron/IPMI.py $(DESTDIR)$(PLUGINDIR)/IPMI.py $(IPROG) poweron/power-on.py $(DESTDIR)$(PLUGINDIR)/power-on-host # YUM plugins $(IPROG) yum-plugins/accesstoken.py $(DESTDIR)$(YUMPLUGINDIR) diff --git a/scripts/poweron/DRAC.py b/scripts/poweron/DRAC.py deleted file mode 100644 index bace3a177a4..00000000000 --- a/scripts/poweron/DRAC.py +++ /dev/null @@ -1,60 +0,0 @@ -#!/usr/bin/env python3 - -import os.path -import sys - -import xcp.cmd as cmd - - -class DRAC_NO_SUPP_PACK(Exception): - """Base Exception class for all transfer plugin errors.""" - - def __init__(self, *args): - Exception.__init__(self, *args) - - -class DRAC_POWERON_FAILED(Exception): - """Base Exception class for all transfer plugin errors.""" - - def __init__(self, *args): - Exception.__init__(self, *args) - - -drac_path = "/opt/dell/srvadmin/sbin/racadm" - - -def DRAC(power_on_ip, user, password): - if not os.path.exists(drac_path): - raise DRAC_NO_SUPP_PACK() - - (rc, stdout, stderr) = cmd.runCmd( - [ - drac_path, - "-r", - power_on_ip, - "-u", - user, - "-p", - password, - "serveraction", - "powerup", - ], - with_stdout=True, - with_stderr=True, - ) - if rc != 0: - raise DRAC_POWERON_FAILED(stderr) - return stdout - - -def main(): - if len(sys.argv) < 3: - exit(0) - ip = sys.argv[1] - user = sys.argv[2] - password = sys.argv[3] - print(DRAC(ip, user, password)) - - -if __name__ == "__main__": - main() diff --git a/scripts/poweron/IPMI.py b/scripts/poweron/IPMI.py new file mode 100644 index 00000000000..73a452af888 --- /dev/null +++ b/scripts/poweron/IPMI.py @@ -0,0 +1,46 @@ +#!/usr/bin/env python3 + +import os.path +import sys + +import xcp.cmd as cmd + + +class IPMI_POWERON_FAILED(Exception): + """IPMI Poweron exception""" + pass + +ipmi_path = "/usr/bin/ipmitool" + +def IPMI(power_on_ip, user, password): + (rc, stdout, stderr) = cmd.runCmd( + [ + ipmi_path, + "-H", + power_on_ip, + "-I", "lanplus", + "-U", + user, + "-P", + password, + "chassis", "power", "on" + ], + with_stdout=True, + with_stderr=True, + ) + if rc != 0: + raise IPMI_POWERON_FAILED(stderr) + return stdout + + +def main(): + if len(sys.argv) < 3: + exit(0) + ip = sys.argv[1] + user = sys.argv[2] + password = sys.argv[3] + print(IPMI(ip, user, password)) + + +if __name__ == "__main__": + main() diff --git a/scripts/poweron/power-on.py b/scripts/poweron/power-on.py index 34fec2f1e60..a76726a5019 100644 --- a/scripts/poweron/power-on.py +++ b/scripts/poweron/power-on.py @@ -41,14 +41,14 @@ def main(session, args): power_on_config = session.xenapi.host.get_power_on_config(remote_host) - if mode == "DRAC": + if mode == "IPMI": ip = power_on_config["power_on_ip"] user = power_on_config["power_on_user"] secret = power_on_config["power_on_password_secret"] secretref = session.xenapi.secret.get_by_uuid(secret) password = session.xenapi.secret.get_value(secretref) - modu = __import__("DRAC") - modu.DRAC(ip, user, password) + modu = __import__("IPMI") + modu.IPMI(ip, user, password) return waitForXapi(session, remote_host) elif mode == "wake-on-lan": modu = __import__("wlan") @@ -60,8 +60,8 @@ def main(session, args): modu = __import__(mode) except ModuleNotFoundError as e: # iLO.py was removed as part of REQ-811, so tell user why they are receiving this error - if mode == "iLO": - syslog.syslog(syslog.LOG_ERR, "iLO script was removed") + if mode in ["iLO", "DRAC"]: + syslog.syslog(syslog.LOG_ERR, f"{mode} script has been removed") raise e modu.custom(session, remote_host, power_on_config) From 6e09fc568df9a0816dfa6a396960d907dd0b41e0 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 5 Jul 2024 10:20:21 +0100 Subject: [PATCH 35/44] opam: generate xapi-forkexecd with dune Signed-off-by: Pau Ruiz Safont --- dune-project | 21 +++++++++++++++ forkexec.opam | 52 ++++++++++++++++++++---------------- forkexec.opam.template | 29 -------------------- xapi-forkexecd.opam | 51 ++++++++++++++++++----------------- xapi-forkexecd.opam.template | 30 --------------------- 5 files changed, 76 insertions(+), 107 deletions(-) delete mode 100644 forkexec.opam.template delete mode 100644 xapi-forkexecd.opam.template diff --git a/dune-project b/dune-project index 3240d722d69..ba66a2c0096 100644 --- a/dune-project +++ b/dune-project @@ -241,6 +241,14 @@ (package (name xapi-forkexecd) + (synopsis "Sub-process control service for xapi") + (description "This daemon creates and manages sub-processes on behalf of xapi.") + (depends + astring + (forkexec (= :version)) + (uuid (= :version)) + (xapi-stdext-unix (= :version)) + ) ) (package @@ -444,6 +452,19 @@ This package provides an Lwt compatible interface to the library.") (package (name forkexec) + (synopsis "Process-spawning library") + (description "Client and server library to spawn processes.") + (depends + base-threads + (fd-send-recv (>= "2.0.0")) + ppx_deriving_rpc + rpclib + (uuid (= :version)) + (xapi-log (= :version)) + (xapi-stdext-pervasives (= :version)) + (xapi-stdext-unix (= :version)) + (xapi-tracing (= :version)) + ) ) (package diff --git a/forkexec.opam b/forkexec.opam index a3296ea9771..3aea97441c2 100644 --- a/forkexec.opam +++ b/forkexec.opam @@ -1,31 +1,37 @@ # This file is generated by dune, edit dune-project instead -license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: "xen-api@lists.xen.org" -homepage: "https://github.com/xapi-project/" +synopsis: "Process-spawning library" +description: "Client and server library to spawn processes." +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - depends: [ - "ocaml" - "dune" + "dune" {>= "3.0"} "base-threads" - "fd-send-recv" + "fd-send-recv" {>= "2.0.0"} "ppx_deriving_rpc" "rpclib" - "uuid" - "xapi-log" - "xapi-stdext-pervasives" - "xapi-stdext-unix" - "xapi-tracing" + "uuid" {= version} + "xapi-log" {= version} + "xapi-stdext-pervasives" {= version} + "xapi-stdext-unix" {= version} + "xapi-tracing" {= version} + "odoc" {with-doc} ] -synopsis: "Sub-process control service for xapi" -description: - "This daemon creates and manages sub-processes on behalf of xapi." -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" diff --git a/forkexec.opam.template b/forkexec.opam.template deleted file mode 100644 index cf537533421..00000000000 --- a/forkexec.opam.template +++ /dev/null @@ -1,29 +0,0 @@ -opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: "xen-api@lists.xen.org" -homepage: "https://github.com/xapi-project/" -bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - -depends: [ - "ocaml" - "dune" - "base-threads" - "fd-send-recv" - "ppx_deriving_rpc" - "rpclib" - "uuid" - "xapi-log" - "xapi-stdext-pervasives" - "xapi-stdext-unix" - "xapi-tracing" -] -synopsis: "Sub-process control service for xapi" -description: - "This daemon creates and manages sub-processes on behalf of xapi." -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} diff --git a/xapi-forkexecd.opam b/xapi-forkexecd.opam index 51ce3a48d0a..900419be134 100644 --- a/xapi-forkexecd.opam +++ b/xapi-forkexecd.opam @@ -1,32 +1,33 @@ # This file is generated by dune, edit dune-project instead -license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: "xen-api@lists.xen.org" -homepage: "https://github.com/xapi-project/" +synopsis: "Sub-process control service for xapi" +description: + "This daemon creates and manages sub-processes on behalf of xapi." +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -tags: [ "org:xapi-project" ] - -build: [ - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] depends: [ - "ocaml" - "dune" + "dune" {>= "3.0"} "astring" - "forkexec" - "systemd" {>= "1.2"} - "uuid" - "xapi-stdext-unix" + "forkexec" {= version} + "uuid" {= version} + "xapi-stdext-unix" {= version} + "odoc" {with-doc} ] -conflicts: [ - "fd-send-recv" {< "2.0.0"} +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] ] -synopsis: "Sub-process control service for xapi" -description: - "This daemon creates and manages sub-processes on behalf of xapi." -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} +dev-repo: "git+https://github.com/xapi-project/xen-api.git" diff --git a/xapi-forkexecd.opam.template b/xapi-forkexecd.opam.template deleted file mode 100644 index 1c81daf10be..00000000000 --- a/xapi-forkexecd.opam.template +++ /dev/null @@ -1,30 +0,0 @@ -opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: "xen-api@lists.xen.org" -homepage: "https://github.com/xapi-project/" -bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -tags: [ "org:xapi-project" ] - -build: [ - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -depends: [ - "ocaml" - "dune" - "astring" - "forkexec" - "systemd" {>= "1.2"} - "uuid" - "xapi-stdext-unix" -] -conflicts: [ - "fd-send-recv" {< "2.0.0"} -] -synopsis: "Sub-process control service for xapi" -description: - "This daemon creates and manages sub-processes on behalf of xapi." -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} From 3f5e62d89a613f0da9f7fc6de5125ba20a364649 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 5 Jul 2024 10:21:14 +0100 Subject: [PATCH 36/44] opam: remove unversioned opam dependencies Signed-off-by: Pau Ruiz Safont --- dune-project | 2 -- xapi-stdext-threads.opam | 1 - xapi-stdext-zerocheck.opam | 1 - 3 files changed, 4 deletions(-) diff --git a/dune-project b/dune-project index ba66a2c0096..20044d49199 100644 --- a/dune-project +++ b/dune-project @@ -534,7 +534,6 @@ This package provides an Lwt compatible interface to the library.") (synopsis "Xapi's standard library extension, Threads") (authors "Jonathan Ludlam") (depends - ocaml base-threads base-unix (odoc :with-doc) @@ -562,7 +561,6 @@ This package provides an Lwt compatible interface to the library.") (synopsis "Xapi's standard library extension, Zerocheck") (authors "Jonathan Ludlam") (depends - ocaml (odoc :with-doc) ) ) diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index de9699fe2e3..58e6fd0509e 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -8,7 +8,6 @@ homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "dune" {>= "3.0"} - "ocaml" "base-threads" "base-unix" "odoc" {with-doc} diff --git a/xapi-stdext-zerocheck.opam b/xapi-stdext-zerocheck.opam index fce24fb209d..6b6dfc62f9b 100644 --- a/xapi-stdext-zerocheck.opam +++ b/xapi-stdext-zerocheck.opam @@ -8,7 +8,6 @@ homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "dune" {>= "3.0"} - "ocaml" "odoc" {with-doc} ] build: [ From 832fd361acd9859a6bf26e6b7a20a19ae31bdee1 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 5 Jul 2024 10:42:18 +0100 Subject: [PATCH 37/44] opam: generate xapi-networkd using dune Signed-off-by: Pau Ruiz Safont --- dune-project | 21 ++++++++++++++ xapi-networkd.opam | 55 +++++++++++++++++++++---------------- xapi-networkd.opam.template | 35 ----------------------- 3 files changed, 52 insertions(+), 59 deletions(-) delete mode 100644 xapi-networkd.opam.template diff --git a/dune-project b/dune-project index 20044d49199..cd4d286416c 100644 --- a/dune-project +++ b/dune-project @@ -225,6 +225,27 @@ (package (name xapi-networkd) + (authors "Jon Ludlam") + (synopsis "The XCP networking daemon") + (depends + (alcotest :with-test) + astring + base-threads + (forkexec (= :version)) + (http-lib (= :version)) + mtime + netlink + re + rpclib + (xapi-idl (= :version)) + xapi-inventory + (xapi-stdext-pervasives (= :version)) + (xapi-stdext-std (= :version)) + (xapi-stdext-threads (= :version)) + (xapi-stdext-unix (= :version)) + xapi-test-utils + (xen-api-client (= :version)) + ) ) (package diff --git a/xapi-networkd.opam b/xapi-networkd.opam index 6a3f122d14f..595478821f2 100644 --- a/xapi-networkd.opam +++ b/xapi-networkd.opam @@ -1,37 +1,44 @@ # This file is generated by dune, edit dune-project instead -license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: "jonathan.ludlam@eu.citrix.com" -homepage: "https://github.com/xapi-project/xen-api" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" +synopsis: "The XCP networking daemon" +maintainer: ["Xapi project maintainers"] +authors: ["Jon Ludlam"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" -build: [ - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] depends: [ - "astring" + "dune" {>= "3.0"} "alcotest" {with-test} + "astring" "base-threads" - "forkexec" - "http-lib" + "forkexec" {= version} + "http-lib" {= version} "mtime" "netlink" "re" "rpclib" - "systemd" - "xapi-idl" + "xapi-idl" {= version} "xapi-inventory" - "xapi-stdext-pervasives" - "xapi-stdext-std" - "xapi-stdext-threads" - "xapi-stdext-unix" + "xapi-stdext-pervasives" {= version} + "xapi-stdext-std" {= version} + "xapi-stdext-threads" {= version} + "xapi-stdext-unix" {= version} "xapi-test-utils" - "xen-api-client" + "xen-api-client" {= version} + "odoc" {with-doc} ] -synopsis: "The XCP networking daemon" -url { - src: - "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" diff --git a/xapi-networkd.opam.template b/xapi-networkd.opam.template deleted file mode 100644 index b661773e09e..00000000000 --- a/xapi-networkd.opam.template +++ /dev/null @@ -1,35 +0,0 @@ -opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: "jonathan.ludlam@eu.citrix.com" -homepage: "https://github.com/xapi-project/xen-api" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -bug-reports: "https://github.com/xapi-project/xen-api/issues" -build: [ - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -depends: [ - "astring" - "alcotest" {with-test} - "base-threads" - "forkexec" - "http-lib" - "mtime" - "netlink" - "re" - "rpclib" - "systemd" - "xapi-idl" - "xapi-inventory" - "xapi-stdext-pervasives" - "xapi-stdext-std" - "xapi-stdext-threads" - "xapi-stdext-unix" - "xapi-test-utils" - "xen-api-client" -] -synopsis: "The XCP networking daemon" -url { - src: - "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} From 1b06e51cefecd38b24934afc0422a167647d8a3f Mon Sep 17 00:00:00 2001 From: Alex Brett Date: Fri, 5 Jul 2024 10:50:22 +0000 Subject: [PATCH 38/44] IH-621 Add changed line to power_on_mode As per review comment. Signed-off-by: Alex Brett --- ocaml/idl/datamodel_host.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/ocaml/idl/datamodel_host.ml b/ocaml/idl/datamodel_host.ml index dad24eabf17..b7d34350819 100644 --- a/ocaml/idl/datamodel_host.ml +++ b/ocaml/idl/datamodel_host.ml @@ -1367,6 +1367,7 @@ let set_power_on_mode = [ (Published, rel_cowley, "") ; (Changed, rel_stockholm, "Removed iLO script") + ; (Changed, "24.19.0", "Replaced DRAC mode with IPMI") ] ~in_product_since:rel_midnight_ride ~doc:"Set the power-on-mode, host, user and password" From 77987d5208926a126bc10314f0e927e08b5be7b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 5 Jul 2024 16:28:32 +0100 Subject: [PATCH 39/44] fe_test: print stacktrace on unit test failure MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/forkexecd/test/fe_test.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ocaml/forkexecd/test/fe_test.ml b/ocaml/forkexecd/test/fe_test.ml index b5146b9e302..bdd4d5c774b 100644 --- a/ocaml/forkexecd/test/fe_test.ml +++ b/ocaml/forkexecd/test/fe_test.ml @@ -221,9 +221,10 @@ let test_internal_failure_error () = Forkhelpers.safe_close_and_exec None (Some fd) None [] exe args |> ignore ; fail "Expected an exception" with - | Fd_send_recv.Unix_error _ -> + | Fd_send_recv.Unix_error _ | Unix.Unix_error (Unix.EBADF, _, _) -> leak_fd_detect () | e -> + Printexc.print_backtrace stderr; fail "Failed with unexpected exception: %s" (Printexc.to_string e) let master fds = From 4ea60894a7cc56daf0ab7be1e6269a8af89c968e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 5 Jul 2024 16:29:03 +0100 Subject: [PATCH 40/44] fix(fe_test): make it compatible with fd-send-recv 2.0.2 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 2.0.2 dropped Fd_send_recv.Unix_error, and only raises Unix.Unix_error (Although the type itself is still present for backwards compatibility). Catch both exceptions, this now passes on both OCaml 4 and OCaml 5.2. Eventually we'll want to drop the Fd_send_recv.Unix_error from here and from the library itself once we've updated to it. Signed-off-by: Edwin Török --- ocaml/forkexecd/test/fe_test.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/forkexecd/test/fe_test.ml b/ocaml/forkexecd/test/fe_test.ml index bdd4d5c774b..870ac591601 100644 --- a/ocaml/forkexecd/test/fe_test.ml +++ b/ocaml/forkexecd/test/fe_test.ml @@ -224,7 +224,7 @@ let test_internal_failure_error () = | Fd_send_recv.Unix_error _ | Unix.Unix_error (Unix.EBADF, _, _) -> leak_fd_detect () | e -> - Printexc.print_backtrace stderr; + Printexc.print_backtrace stderr ; fail "Failed with unexpected exception: %s" (Printexc.to_string e) let master fds = From 331c564e0f6d472dc456c2f34cf6ca5d5c248a29 Mon Sep 17 00:00:00 2001 From: Alex Brett Date: Fri, 5 Jul 2024 15:37:10 +0000 Subject: [PATCH 41/44] IH-621: Python tweaks suggested by pylint Signed-off-by: Alex Brett --- scripts/poweron/IPMI.py | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/scripts/poweron/IPMI.py b/scripts/poweron/IPMI.py index 73a452af888..0f70607bf6f 100644 --- a/scripts/poweron/IPMI.py +++ b/scripts/poweron/IPMI.py @@ -1,10 +1,7 @@ #!/usr/bin/env python3 -import os.path import sys - -import xcp.cmd as cmd - +from xcp import cmd class IPMI_POWERON_FAILED(Exception): """IPMI Poweron exception""" @@ -35,7 +32,7 @@ def IPMI(power_on_ip, user, password): def main(): if len(sys.argv) < 3: - exit(0) + sys.exit(1) ip = sys.argv[1] user = sys.argv[2] password = sys.argv[3] From 92c51d7f332424bca3aef320a2b3e936ae6c7e67 Mon Sep 17 00:00:00 2001 From: Frediano Ziglio Date: Mon, 8 Jul 2024 09:26:42 +0000 Subject: [PATCH 42/44] Fix indentation in C code Coherently use tabs instead of spaces. Just style changes. Signed-off-by: Frediano Ziglio --- ocaml/xenopsd/c_stubs/sockopt_stubs.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/ocaml/xenopsd/c_stubs/sockopt_stubs.c b/ocaml/xenopsd/c_stubs/sockopt_stubs.c index 831eadc260f..5acf239d758 100644 --- a/ocaml/xenopsd/c_stubs/sockopt_stubs.c +++ b/ocaml/xenopsd/c_stubs/sockopt_stubs.c @@ -45,25 +45,25 @@ CAMLprim value stub_sockopt_set_sock_keepalives(value fd, value count, value idle, value interval) { - CAMLparam4(fd, count, idle, interval); + CAMLparam4(fd, count, idle, interval); int c_fd = Int_val(fd); int optval; - socklen_t optlen=sizeof(optval); + socklen_t optlen = sizeof(optval); optval = Int_val(count); if(setsockopt(c_fd, TCP_LEVEL, TCP_KEEPCNT, &optval, optlen) < 0) { - uerror("setsockopt(TCP_KEEPCNT)", Nothing); + uerror("setsockopt(TCP_KEEPCNT)", Nothing); } #if defined(__linux__) optval = Int_val(idle); if(setsockopt(c_fd, TCP_LEVEL, TCP_KEEPIDLE, &optval, optlen) < 0) { - uerror("setsockopt(TCP_KEEPIDLE)", Nothing); + uerror("setsockopt(TCP_KEEPIDLE)", Nothing); } #endif optval = Int_val(interval); if(setsockopt(c_fd, TCP_LEVEL, TCP_KEEPINTVL, &optval, optlen) < 0) { - uerror("setsockopt(TCP_KEEPINTVL)", Nothing); + uerror("setsockopt(TCP_KEEPINTVL)", Nothing); } CAMLreturn(Val_unit); From d26f8705747ae79c6ccd9173d2e1b2649f59c8f1 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Tue, 9 Jul 2024 10:44:26 +0100 Subject: [PATCH 43/44] Fixes: 99c43569a0 ("Transition from exception-raising Unix.getenv to Sys.getenv_opt with") Signed-off-by: Andrii Sultanov --- ocaml/xapi-idl/lib/xcp_service.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi-idl/lib/xcp_service.ml b/ocaml/xapi-idl/lib/xcp_service.ml index 667e51bd74f..69217d8328c 100644 --- a/ocaml/xapi-idl/lib/xcp_service.ml +++ b/ocaml/xapi-idl/lib/xcp_service.ml @@ -371,10 +371,10 @@ let canonicalise x = split_c ':' (Option.value (Sys.getenv_opt "PATH") ~default:"") in let first_hit = - List.find_opt + List.find_map (fun path -> let possibility = Filename.concat path x in - Sys.file_exists possibility + if Sys.file_exists possibility then Some possibility else None ) (paths @ !extra_search_path) in From 73f5a30296b702dae579c66d4296bcdc39f31f02 Mon Sep 17 00:00:00 2001 From: Colin James Date: Thu, 4 Jul 2024 15:27:13 +0100 Subject: [PATCH 44/44] IH-642 Restructure xs-trace to use Cmdliner The xs-trace utility is restructured to enhance its readability and, to aid with potential future extension, its CLI is reimplemented in terms of Cmdliner. It is hoped that the current command modes are consistent with what was already expected by xs-trace, i.e. xs-trace (cp|mv) These changes should make it simpler to extend this utility with more functionality. For example, there is an idea to add some short conversion routines from Zipkinv2 to Google's Catapult trace format - so that single host triaging can bypass heavy distributed tracing services and use functionality built into Chrome (or the online Perfetto trace viewer). Signed-off-by: Colin James --- ocaml/xs-trace/dune | 13 ++++ ocaml/xs-trace/xs_trace.ml | 126 +++++++++++++++++++++++++------------ 2 files changed, 98 insertions(+), 41 deletions(-) diff --git a/ocaml/xs-trace/dune b/ocaml/xs-trace/dune index b168c190faa..05e485a2c0a 100644 --- a/ocaml/xs-trace/dune +++ b/ocaml/xs-trace/dune @@ -4,7 +4,20 @@ (public_name xs-trace) (package xapi) (libraries + cmdliner tracing_export xapi-stdext-unix ) ) + +(rule + (targets xs-trace.1) + (deps (:exe xs_trace.exe)) + (action (with-stdout-to %{targets} (run %{exe} --help=groff))) +) + +(install + (section man) + (package xapi) + (files (xs-trace.1 as man1/xs-trace.1)) +) diff --git a/ocaml/xs-trace/xs_trace.ml b/ocaml/xs-trace/xs_trace.ml index 9d481e0e7a4..e51847c9256 100644 --- a/ocaml/xs-trace/xs_trace.ml +++ b/ocaml/xs-trace/xs_trace.ml @@ -12,48 +12,92 @@ * GNU Lesser General Public License for more details. *) -let _ = - match Sys.argv with - | [|_; action; origin; url_string|] -> - let url = Uri.of_string url_string in - let submit_json json = - if json <> "" then - let result = Tracing_export.Destination.Http.export ~url json in - match result with - | Ok _ -> - () - | Error err -> - Printf.eprintf "Error: %s" (Printexc.to_string err) ; - exit 1 - in - let rec export_file orig = - if Sys.is_directory orig then - let files = Sys.readdir orig in - let file_paths = Array.map (Filename.concat orig) files in - Array.iter export_file file_paths - else if Filename.check_suffix orig ".zst" then - Xapi_stdext_unix.Unixext.with_file orig [O_RDONLY] 0o000 - @@ fun compressed_file -> - Zstd.Fast.decompress_passive compressed_file @@ fun decompressed -> - if Filename.check_suffix orig ".ndjson.zst" then +module Exporter = struct + module Unixext = Xapi_stdext_unix.Unixext + + (* Submit JSON to a specified endpoint. *) + let submit_json url json = + if json <> "" then + match Tracing_export.Destination.Http.export ~url json with + | Error err -> + Printf.eprintf "Error: %s" (Printexc.to_string err) ; + exit 1 + | _ -> + () + + (** Export traces from file system to a remote endpoint. *) + let export erase src dst = + let dst = Uri.of_string dst in + let submit_json = submit_json dst in + let rec export_file = function + | path when Sys.is_directory path -> + (* Recursively export trace files. *) + Sys.readdir path + |> Array.iter (fun f -> Filename.concat path f |> export_file) + | path when Filename.check_suffix path ".zst" -> + (* Decompress compressed trace file and decide whether to + treat it as line-delimited or not. *) + let ( let@ ) = ( @@ ) in + let@ compressed = Unixext.with_file path [O_RDONLY] 0o000 in + let@ decompressed = Zstd.Fast.decompress_passive compressed in + if Filename.check_suffix path ".ndjson.zst" then let ic = Unix.in_channel_of_descr decompressed in - Xapi_stdext_unix.Unixext.lines_iter - (fun line -> submit_json line) - ic + Unixext.lines_iter submit_json ic else - let json = Xapi_stdext_unix.Unixext.string_of_fd decompressed in + let json = Unixext.string_of_fd decompressed in submit_json json - else if Filename.check_suffix orig ".ndjson" then - Xapi_stdext_unix.Unixext.readfile_line - (fun line -> submit_json line) - orig - else - let json = Xapi_stdext_unix.Unixext.string_of_file orig in + | path when Filename.check_suffix path ".ndjson" -> + (* Submit traces line by line. *) + Unixext.readfile_line submit_json path + | path -> + (* Assume any other extension is a valid JSON file. *) + let json = Unixext.string_of_file path in submit_json json - in - export_file origin ; - if action = "mv" then - Xapi_stdext_unix.Unixext.rm_rec ~rm_top:true origin - | _ -> - Printf.eprintf "Usage: %s cp/mv \n" Sys.argv.(0) ; - exit 1 + in + export_file src ; + if erase then + Unixext.rm_rec ~rm_top:true src +end + +module Cli = struct + open Cmdliner + + let src = + let doc = "The trace file, e.g. /path/to/trace.ndjson" in + Arg.(required & pos 0 (some string) None (info [] ~docv:"SRC" ~doc)) + + let dst = + let doc = + "The destination endpoint URL, e.g. http://localhost:9411/api/v2/spans" + in + Arg.(required & pos 1 (some string) None (info [] ~docv:"DST" ~doc)) + + let export_term ~erase = Term.(const Exporter.export $ const erase $ src $ dst) + + let cp_cmd = + let term = export_term ~erase:false in + let doc = "copy a trace to an endpoint" in + Cmd.(v (info "cp" ~doc) term) + + let mv_cmd = + let term = export_term ~erase:true in + let doc = "copy a trace to an endpoint and erase it afterwards" in + Cmd.(v (info "mv" ~doc) term) + + let xs_trace_cmd = + let man = + [ + `S "DESCRIPTION" + ; `P "$(mname) is a utility for working with local trace files" + ] + in + let desc = + let doc = "utility for working with local trace files" in + Cmd.info "xs-trace" ~doc ~version:"0.1" ~man + in + Cmd.group desc [cp_cmd; mv_cmd] + + let main () = Cmd.eval xs_trace_cmd +end + +let () = exit (Cli.main ())