diff --git a/ocaml/idl/datamodel.ml b/ocaml/idl/datamodel.ml index 9345bd18313..eca871fa6d5 100644 --- a/ocaml/idl/datamodel.ml +++ b/ocaml/idl/datamodel.ml @@ -7866,6 +7866,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) *) @@ -7946,6 +7947,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 = @@ -8077,6 +8079,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 962ad7bdd39..de22cf2e5ad 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 71f08f8bd90..04d56597ea8 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1966,6 +1966,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_pool.ml b/ocaml/idl/datamodel_pool.ml index 11d84ce22e3..4e7336dc2d6 100644 --- a/ocaml/idl/datamodel_pool.ml +++ b/ocaml/idl/datamodel_pool.ml @@ -1511,6 +1511,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/datamodel_vm.ml b/ocaml/idl/datamodel_vm.ml index 67037dce12a..bf6fe168f8a 100644 --- a/ocaml/idl/datamodel_vm.ml +++ b/ocaml/idl/datamodel_vm.ml @@ -1514,6 +1514,16 @@ 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") + ] + ~errs:[Api_errors.operation_not_allowed] + ~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" @@ -1887,6 +1897,7 @@ let t = ; recover ; import_convert ; set_appliance + ; set_groups ; query_services ; call_plugin ; set_has_vendor_device @@ -2218,6 +2229,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 8ec11645226..f2ee8fe4be2 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 = "e34cd0d32cdcec7805c2d3ed4e4a0c25" +let last_known_schema_hash = "efdb1c7e536362523741ccdb7f33f797" 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 6cf72c77ef8..90dfe287801 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 = @@ -675,3 +676,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_ha_vm_failover.ml b/ocaml/tests/test_ha_vm_failover.ml index 4ab377870ab..fe915563e18 100644 --- a/ocaml/tests/test_ha_vm_failover.ml +++ b/ocaml/tests/test_ha_vm_failover.ml @@ -27,6 +27,10 @@ type vbd = {agile: bool} type vif = {agile: bool} +type placement_policy = AntiAffinity | Normal + +type group = {name_label: string; placement: placement_policy} + type vm = { ha_always_run: bool ; ha_restart_priority: string @@ -34,6 +38,8 @@ type vm = { ; name_label: string ; vbds: vbd list ; vifs: vif list + ; groups: group list + ; power_state: string } let basic_vm = @@ -44,6 +50,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 +63,67 @@ type pool = { ; cluster: int } -let string_of_vm {memory; name_label; _} = - Printf.sprintf "{memory = %Ld; name_label = %S}" memory name_label +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 + (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 + 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 +138,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 + | AntiAffinity -> + `anti_affinity + | Normal -> + `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 +185,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 +205,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 @@ -184,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 @@ -196,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= ""} @@ -213,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= [] @@ -224,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 @@ -237,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 } ] } @@ -253,7 +351,7 @@ module AllProtectedVms = Generic.MakeStateful (struct ; ha_host_failures_to_tolerate= 0L ; cluster= 0 } - , ["vm1"] + , [vm1] ) ] end) @@ -293,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 } @@ -306,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 } @@ -320,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 } @@ -338,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} ] } ] @@ -422,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 } @@ -434,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 () @@ -445,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 } @@ -461,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 @@ -475,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 @@ -498,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 () @@ -533,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 @@ -548,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 } @@ -558,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 } @@ -569,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/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 + ) + ] 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)] diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index 13c695da5db..3c2c617fddf 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -2686,6 +2686,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 54eace11b69..6aee526f497 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -1142,6 +1142,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"; "pci-uuid"; "vendor-name"; "device-name"; "gpu-group-uuid"] @@ -8000,3 +8005,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 6ee45dce5dd..92322264e36 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -1226,3 +1226,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 2b3a562d4f5..abcd5f3fb1c 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -1495,6 +1495,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) + () ] } @@ -2506,6 +2512,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 -> @@ -4072,6 +4093,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 5616ba3a1c5..3998068378a 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1375,3 +1375,5 @@ let telemetry_next_collection_too_late = (* FIPS/CC_PREPARATIONS *) let illegal_in_fips_mode = add_error "ILLEGAL_IN_FIPS_MODE" + +let too_many_groups = "TOO_MANY_GROUPS" 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-types/features.ml b/ocaml/xapi-types/features.ml index 37fafc0905a..6e838f32b83 100644 --- a/ocaml/xapi-types/features.ml +++ b/ocaml/xapi-types/features.ml @@ -64,6 +64,7 @@ type feature = | Updates | Internal_repo_access | VTPM + | VM_groups [@@deriving rpc] type orientation = Positive | Negative @@ -132,6 +133,7 @@ let keys_of_features = , ("restrict_internal_repo_access", Negative, "Internal_repo_access") ) ; (VTPM, ("restrict_vtpm", Negative, "VTPM")) + ; (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 c2f1ed2a51b..bcd1ef4ac66 100644 --- a/ocaml/xapi-types/features.mli +++ b/ocaml/xapi-types/features.mli @@ -72,6 +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_groups (** Enable use of VM groups *) val feature_of_rpc : Rpc.t -> feature (** Convert RPC into {!feature}s *) diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index 9194a31b122..c5870d8555f 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/dbsync_master.ml b/ocaml/xapi/dbsync_master.ml index fbe0dc9273a..8f8e6a582f8 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 *) @@ -53,7 +54,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 = @@ -339,6 +340,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 = @@ -363,4 +376,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/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/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 6be9f50d4c0..935ed8cf7e8 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 @@ -3017,6 +3028,15 @@ 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)) ; + 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 = info "VM.import_convert: type = '%s'; remote_config = '%s;'" _type @@ -6568,6 +6588,23 @@ 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) ; + Xapi_vm_group_helpers.remove_vm_anti_affinity_alert ~__context + ~groups:[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/pool_features.ml b/ocaml/xapi/pool_features.ml index d3a14dd5221..8821224872a 100644 --- a/ocaml/xapi/pool_features.ml +++ b/ocaml/xapi/pool_features.ml @@ -13,22 +13,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 +35,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 100644 index 00000000000..dda8619013c --- /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.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 new file mode 100755 index 00000000000..d5d610a3544 --- /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/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 7dbfb8da582..ad4f35e37ed 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -1036,6 +1036,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 disable_webserver = ref false let xapi_globs_spec = @@ -1856,6 +1858,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 = diff --git a/ocaml/xapi/xapi_ha_vm_failover.ml b/ocaml/xapi/xapi_ha_vm_failover.ml index 4fbf46860f2..4aa9ee17128 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,418 @@ 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 + (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 + 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 +604,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. *) 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 diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 01b76be3d85..7e767dbd035 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -1109,7 +1109,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" ; @@ -2025,7 +2025,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 7013706ead1..ee08e18cf95 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -1994,7 +1994,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 diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 9e510baa4de..8a03aba27e1 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1441,6 +1441,26 @@ 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 = + 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 + || 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 + 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 273d0d6f2ca..19a737755e0 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..f2a7497737b --- /dev/null +++ b/ocaml/xapi/xapi_vm_group.ml @@ -0,0 +1,29 @@ +(* + * 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 = + 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 + ~name_description ~placement ; + ref + +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 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_group_helpers.ml b/ocaml/xapi/xapi_vm_group_helpers.ml new file mode 100644 index 00000000000..87fc15b10b5 --- /dev/null +++ b/ocaml/xapi/xapi_vm_group_helpers.ml @@ -0,0 +1,213 @@ +(* + * 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 = + if Pool_features.is_enabled ~__context Features.VM_groups 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" + (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 = + if Pool_features.is_enabled ~__context Features.VM_groups 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 + ~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_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 + | 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..e2800ee69db --- /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_groups 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_group", "false") + ] +*) diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index d8b9855686e..989686ca2dc 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 HostMap = 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 @@ -114,7 +120,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) @@ -904,6 +912,26 @@ 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 = + 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) + |> 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 | [] -> @@ -923,7 +951,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 -> @@ -969,12 +1001,112 @@ 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) + +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 + +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 + 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 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 = + hosts_without_affinity + |> rank_hosts_by_vm_cnt_in_group ~__context group + |> List.(map (map fst)) + in + 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) 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) hosts_str ; + 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 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 = @@ -986,6 +1118,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 @@ -1000,7 +1134,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 @@ -1012,22 +1146,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 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 8fb445aace1..e57ef22fbad 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -500,7 +500,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 diff --git a/ocaml/xapi/xapi_vm_snapshot.ml b/ocaml/xapi/xapi_vm_snapshot.ml index 747fd68deb3..49f745a8845 100644 --- a/ocaml/xapi/xapi_vm_snapshot.ml +++ b/ocaml/xapi/xapi_vm_snapshot.ml @@ -385,6 +385,7 @@ let do_not_copy = "snapshots" ; "tags" ; "affinity" + ; "groups" ; (* Current fields should remain to get destroyed during revert process *) "consoles" ; "VBDs" 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