CP-47656 VM anti-affinity generate breach alert

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

ocaml/xapi/message_forwarding.ml

@@ -3011,7 +3011,10 @@ functor
         info "VM.set_groups : self = '%s'; value = [ %s ]"
           (vm_uuid ~__context self)
           (String.concat "; " (List.map (vm_group_uuid ~__context) value)) ;
-        Local.VM.set_groups ~__context ~self ~value
+        let original_groups = Db.VM.get_groups ~__context ~self in
+        Local.VM.set_groups ~__context ~self ~value ;
+        Xapi_vm_group_helpers.update_vm_anti_affinity_alert ~__context
+          ~groups:(original_groups @ value)
 
       let import_convert ~__context ~_type ~username ~password ~sr
           ~remote_config =
@@ -6564,6 +6567,8 @@ functor
 
       let destroy ~__context ~self =
         info "VM_group.destroy: self = '%s'" (vm_group_uuid ~__context self) ;
+        Xapi_vm_group_helpers.remove_vm_anti_affinity_alert ~__context
+          ~groups:[self] ;
         Local.VM_group.destroy ~__context ~self
     end
 

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
-  )

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. *)

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
+  )

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

ocaml/xapi/xapi_host.ml

@@ -1120,7 +1120,7 @@ let destroy ~__context ~self =
   Db.Host.destroy ~__context ~self ;
   Create_misc.create_pool_cpuinfo ~__context ;
   List.iter (fun vm -> Db.VM.destroy ~__context ~self:vm) my_control_domains ;
-  Pool_features.update_pool_features ~__context
+  Pool_features_helpers.update_pool_features ~__context
 
 let declare_dead ~__context ~host =
   precheck_destroy_declare_dead ~__context ~self:host "declare_dead" ;
@@ -2032,7 +2032,7 @@ let copy_license_to_db ~__context ~host:_ ~features ~additional =
 
 let set_license_params ~__context ~self ~value =
   Db.Host.set_license_params ~__context ~self ~value ;
-  Pool_features.update_pool_features ~__context
+  Pool_features_helpers.update_pool_features ~__context
 
 let apply_edition_internal ~__context ~host ~edition ~additional =
   (* Get localhost's current license state. *)

ocaml/xapi/xapi_pool.ml

@@ -1991,7 +1991,7 @@ let eject ~__context ~host =
       Create_misc.create_pool_cpuinfo ~__context ;
       (* Update pool features, in case this host had a different license to the
        * rest of the pool. *)
-      Pool_features.update_pool_features ~__context
+      Pool_features_helpers.update_pool_features ~__context
   | true, true ->
       raise Cannot_eject_master