CP-47304: Add anti-affinity groups to the datamodel

ocaml/idl/datamodel.ml

@@ -7816,6 +7816,7 @@ let all_system =
   ; Datamodel_diagnostics.t
   ; Datamodel_repository.t
   ; Datamodel_observer.t
+  ; Datamodel_vm_group.t
   ]
 
 (* If the relation is one-to-many, the "many" nodes (one edge each) must come before the "one" node (many edges) *)
@@ -7896,6 +7897,7 @@ let all_relations =
   ; ((_network_sriov, "physical_PIF"), (_pif, "sriov_physical_PIF_of"))
   ; ((_network_sriov, "logical_PIF"), (_pif, "sriov_logical_PIF_of"))
   ; ((_certificate, "host"), (_host, "certificates"))
+  ; ((_vm, "groups"), (_vm_group, "VMs"))
   ]
 
 let update_lifecycles =
@@ -8027,6 +8029,7 @@ let expose_get_all_messages_for =
   ; _vmpp
   ; _vmss
   ; _vm_appliance
+  ; _vm_group
   ; _pci
   ; _pgpu
   ; _gpu_group

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"

ocaml/idl/datamodel_errors.ml

@@ -1968,6 +1968,8 @@ let _ =
   error Api_errors.host_evacuation_is_required ["host"]
     ~doc:"Host evacuation is required before applying updates." () ;
 
+  error Api_errors.too_many_groups [] ~doc:"VM can only belong to one group." () ;
+
   message
     (fst Api_messages.ha_pool_overcommitted)
     ~doc:

ocaml/idl/datamodel_vm.ml

@@ -1514,6 +1514,15 @@ let set_appliance =
       ]
     ~allowed_roles:_R_POOL_OP ()
 
+let set_groups =
+  call ~name:"set_groups" ~lifecycle:[] ~doc:"Associate this VM with VM groups."
+    ~params:
+      [
+        (Ref _vm, "self", "The VM")
+      ; (Set (Ref _vm_group), "value", "The VM groups to set")
+      ]
+    ~allowed_roles:_R_VM_ADMIN ()
+
 let call_plugin =
   call ~name:"call_plugin" ~in_product_since:rel_cream
     ~doc:"Call an API plugin on this vm"
@@ -1826,6 +1835,7 @@ let t =
       ; recover
       ; import_convert
       ; set_appliance
+      ; set_groups
       ; query_services
       ; call_plugin
       ; set_has_vendor_device
@@ -2174,6 +2184,8 @@ let t =
              user should follow to make some updates, e.g. specific hardware \
              drivers or CPU features, fully effective, but the 'average user' \
              doesn't need to"
+        ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:(Set (Ref _vm_group))
+            "groups" "VM groups associated with the VM"
         ]
       )
     ()

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"
+      ]
+    ()

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

ocaml/idl/schematest.ml

@@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex
 (* BEWARE: if this changes, check that schema has been bumped accordingly in
    ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *)
 
-let last_known_schema_hash = "186131ad48f40dff30246e8e0c0dbf0a"
+let last_known_schema_hash = "bd7bd80ec18a0a7ddce47dcfdaa726b5"
 
 let current_schema_hash : string =
   let open Datamodel_types in

ocaml/tests/common/test_common.ml

@@ -674,3 +674,10 @@ let make_observer ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ())
   Db.Observer.create ~__context ~ref ~uuid ~name_label ~name_description ~hosts
     ~attributes ~endpoints ~components ~enabled ;
   ref
+
+let make_vm_group ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ())
+    ?(name_label = "vm_group") ?(name_description = "") ?(placement = `normal)
+    () =
+  Db.VM_group.create ~__context ~ref ~uuid ~name_label ~name_description
+    ~placement ;
+  ref

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

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

ocaml/xapi-cli-server/cli_frontend.ml

@@ -2647,6 +2647,24 @@ let rec cmdtable_data : (string * cmd_spec) list =
       ; flags= []
       }
     )
+  ; ( "vm-group-create"
+    , {
+        reqd= ["name-label"; "placement"]
+      ; optn= ["name-description"]
+      ; help= "Create a VM group."
+      ; implementation= No_fd Cli_operations.VM_group.create
+      ; flags= []
+      }
+    )
+  ; ( "vm-group-destroy"
+    , {
+        reqd= ["uuid"]
+      ; optn= []
+      ; help= "Destroy a VM group."
+      ; implementation= No_fd Cli_operations.VM_group.destroy
+      ; flags= []
+      }
+    )
   ; ( "diagnostic-vm-status"
     , {
         reqd= ["uuid"]

ocaml/xapi-cli-server/cli_operations.ml

@@ -1140,6 +1140,11 @@ let gen_cmds rpc session_id =
         mk get_all_records_where get_by_uuid vm_appliance_record "appliance" []
           [] rpc session_id
       )
+    ; Client.VM_group.(
+        mk get_all_records_where get_by_uuid vm_group_record "vm-group" []
+          ["uuid"; "name-label"; "name-description"; "placement"; "vm-uuids"]
+          rpc session_id
+      )
     ; Client.PGPU.(
         mk get_all_records_where get_by_uuid pgpu_record "pgpu" []
           ["uuid"; "vendor-name"; "device-name"; "gpu-group-uuid"]
@@ -7988,3 +7993,27 @@ module Observer = struct
     let self = Client.Observer.get_by_uuid ~rpc ~session_id ~uuid in
     Client.Observer.destroy ~rpc ~session_id ~self
 end
+
+module VM_group = struct
+  let create printer rpc session_id params =
+    let name_label = List.assoc "name-label" params in
+    let name_description =
+      List.assoc_opt "name-description" params |> Option.value ~default:""
+    in
+    let placement =
+      Record_util.vm_placement_policy_of_string (List.assoc "placement" params)
+    in
+    let ref =
+      Client.VM_group.create ~rpc ~session_id ~name_label ~name_description
+        ~placement
+    in
+    let uuid = Client.VM_group.get_uuid ~rpc ~session_id ~self:ref in
+    printer (Cli_printer.PList [uuid])
+
+  let destroy _printer rpc session_id params =
+    let ref =
+      Client.VM_group.get_by_uuid ~rpc ~session_id
+        ~uuid:(List.assoc "uuid" params)
+    in
+    Client.VM_group.destroy ~rpc ~session_id ~self:ref
+end

ocaml/xapi-cli-server/record_util.ml

@@ -1188,3 +1188,18 @@ let update_sync_frequency_of_string s =
       `weekly
   | _ ->
       raise (Record_failure ("Expected 'daily', 'weekly', got " ^ s))
+
+let vm_placement_policy_to_string = function
+  | `normal ->
+      "normal"
+  | `anti_affinity ->
+      "anti-affinity"
+
+let vm_placement_policy_of_string a =
+  match String.lowercase_ascii a with
+  | "normal" ->
+      `normal
+  | "anti-affinity" ->
+      `anti_affinity
+  | s ->
+      raise (Record_failure ("Invalid VM placement policy, got " ^ s))

ocaml/xapi-cli-server/records.ml

@@ -2504,6 +2504,21 @@ let vm_record rpc session_id vm =
                 ~value:(Client.VM_appliance.get_by_uuid ~rpc ~session_id ~uuid:x)
           )
           ()
+      ; make_field ~name:"groups"
+          ~get:(fun () -> get_uuids_from_refs (x ()).API.vM_groups)
+          ~set:(fun x ->
+            if x = "" then
+              Client.VM.set_groups ~rpc ~session_id ~self:vm ~value:[]
+            else
+              let value =
+                get_words ',' x
+                |> List.map (fun uuid ->
+                       Client.VM_group.get_by_uuid ~rpc ~session_id ~uuid
+                   )
+              in
+              Client.VM.set_groups ~rpc ~session_id ~self:vm ~value
+          )
+          ()
       ; make_field ~name:"snapshot-schedule"
           ~get:(fun () -> get_uuid_from_ref (x ()).API.vM_snapshot_schedule)
           ~set:(fun x ->
@@ -4070,6 +4085,55 @@ let vm_appliance_record rpc session_id vm_appliance =
       ]
   }
 
+let vm_group_record rpc session_id vm_group =
+  let _ref = ref vm_group in
+  let empty_record =
+    ToGet (fun () -> Client.VM_group.get_record ~rpc ~session_id ~self:!_ref)
+  in
+  let record = ref empty_record in
+  let x () = lzy_get record in
+  {
+    setref=
+      (fun r ->
+        _ref := r ;
+        record := empty_record
+      )
+  ; setrefrec=
+      (fun (a, b) ->
+        _ref := a ;
+        record := Got b
+      )
+  ; record= x
+  ; getref= (fun () -> !_ref)
+  ; fields=
+      [
+        make_field ~name:"uuid" ~get:(fun () -> (x ()).API.vM_group_uuid) ()
+      ; make_field ~name:"name-label"
+          ~get:(fun () -> (x ()).API.vM_group_name_label)
+          ~set:(fun value ->
+            Client.VM_group.set_name_label ~rpc ~session_id ~self:!_ref ~value
+          )
+          ()
+      ; make_field ~name:"name-description"
+          ~get:(fun () -> (x ()).API.vM_group_name_description)
+          ~set:(fun value ->
+            Client.VM_group.set_name_description ~rpc ~session_id ~self:!_ref
+              ~value
+          )
+          ()
+      ; make_field ~name:"placement"
+          ~get:(fun () ->
+            Record_util.vm_placement_policy_to_string
+              (x ()).API.vM_group_placement
+          )
+          ()
+      ; make_field ~name:"vm-uuids"
+          ~get:(fun () -> get_uuids_from_refs (x ()).API.vM_group_VMs)
+          ~get_set:(fun () -> List.map get_uuid_from_ref (x ()).API.vM_group_VMs)
+          ()
+      ]
+  }
+
 let dr_task_record rpc session_id dr_task =
   let _ref = ref dr_task in
   let empty_record =

ocaml/xapi-consts/api_errors.ml

@@ -1299,3 +1299,5 @@ let telemetry_next_collection_too_late = "TELEMETRY_NEXT_COLLECTION_TOO_LATE"
 
 (* FIPS/CC_PREPARATIONS *)
 let illegal_in_fips_mode = "ILLEGAL_IN_FIPS_MODE"
+
+let too_many_groups = "TOO_MANY_GROUPS"

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