CP-47304: [Toolstack] - Add data model for anti-affinity group

CP-47655: [Toolstack] - Associate/disassociate VM to/from anti-affinity group

Signed-off-by: Bengang Yuan <[email protected]>

ocaml/idl/datamodel.ml

@@ -5975,6 +5975,61 @@ module VM_appliance = struct
       ()
 end
 
+module VM_group = struct
+  let placement_type =
+    Enum
+      ( "vm_placement_type"
+      , [
+          ("anti_affinity", "VM anti-affinity group")
+        ; ("normal", "Normal type group")
+        ]
+      )
+
+  let create =
+    call ~name:"create" ~in_oss_since:None ~lifecycle:[]
+      ~doc:"Create a new VM group"
+      ~params:
+        [
+          (String, "name_label", "The name of the VM group")
+        ; (String, "name_description", "The description of the VM group")
+        ; (placement_type, "placement", "The placement type of the VM group")
+        ]
+      ~result:(Ref _vm_group, "The ref of the created VM group record")
+      ~allowed_roles:(_R_VM_ADMIN ++ _R_CLIENT_CERT)
+      ()
+
+  let destroy =
+    call ~name:"destroy" ~in_oss_since:None ~lifecycle:[]
+      ~doc:"Remove the VM group record from the database"
+      ~params:
+        [
+          ( Ref _vm_group
+          , "self"
+          , "The Ref of the VM group to be removed from the database"
+          )
+        ]
+      ~allowed_roles:(_R_VM_ADMIN ++ _R_CLIENT_CERT)
+      ()
+
+  let t =
+    create_obj ~name:_vm_group ~descr:"A VM group" ~doccomments:[]
+      ~gen_constructor_destructor:false ~gen_events:true ~in_db:true
+      ~lifecycle:[] ~persist:PersistEverything ~in_oss_since:None
+      ~messages_default_allowed_roles:(_R_VM_ADMIN ++ _R_CLIENT_CERT)
+      ~messages:[create; destroy]
+      ~contents:
+        [
+          uid _vm_group
+        ; namespace ~name:"name" ~contents:(names None RW) ()
+        ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:placement_type "placement"
+            ~default_value:(Some (VEnum "normal"))
+            "The placement type of the VM group"
+        ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:(Set (Ref _vm)) "VMs"
+            "The list of VMs currently associated with the group"
+        ]
+      ()
+end
+
 module DR_task = struct
   (* DR_task *)
   let create =
@@ -7760,6 +7815,7 @@ let all_system =
   ; VMPP.t
   ; VMSS.t
   ; VM_appliance.t
+  ; VM_group.t
   ; DR_task.t
   ; Datamodel_host.t
   ; Host_crashdump.t
@@ -7896,6 +7952,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 +8084,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,9 @@ let _ =
   error Api_errors.host_evacuation_is_required ["host"]
     ~doc:"Host evacuation is required before applying updates." () ;
 
+  error Api_errors.vm_can_only_belong_to_one_anti_affinity_group []
+    ~doc:"The VM can only belong to one anti-affinity group." () ;
+
   message
     (fst Api_messages.ha_pool_overcommitted)
     ~doc:

ocaml/idl/datamodel_vm.ml

@@ -1514,6 +1514,19 @@ let set_appliance =
       ]
     ~allowed_roles:_R_POOL_OP ()
 
+let set_groups =
+  call ~name:"set_groups" ~lifecycle:[]
+    ~doc:"Associate this VM with a VM group."
+    ~params:
+      [
+        (Ref _vm, "self", "The VM")
+      ; ( Set (Ref _vm_group)
+        , "value"
+        , "The VM groups to set (Only one anti-affinity group is supported now)"
+        )
+      ]
+    ~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 +1839,7 @@ let t =
       ; recover
       ; import_convert
       ; set_appliance
+      ; set_groups
       ; query_services
       ; call_plugin
       ; set_has_vendor_device
@@ -2174,6 +2188,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/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 = "1831c310bcce9fb06ad5585c964ccf8c"
 
 let current_schema_hash : string =
   let open Datamodel_types in

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"; "VMs"]
+          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_type_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_type_to_string = function
+  | `normal ->
+      "normal"
+  | `anti_affinity ->
+      "anti-affinity"
+
+let vm_placement_type_of_string a =
+  match String.lowercase_ascii a with
+  | "normal" ->
+      `normal
+  | "anti-affinity" ->
+      `anti_affinity
+  | s ->
+      raise (Record_failure ("Invalid VM placement type, 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_type_to_string
+              (x ()).API.vM_group_placement
+          )
+          ()
+      ; make_field ~name:"VMs"
+          ~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,6 @@ let telemetry_next_collection_too_late = "TELEMETRY_NEXT_COLLECTION_TOO_LATE"
 
 (* FIPS/CC_PREPARATIONS *)
 let illegal_in_fips_mode = "ILLEGAL_IN_FIPS_MODE"
+
+let vm_can_only_belong_to_one_anti_affinity_group =
+  "VM_CAN_ONLY_BELONG_TO_ONE_ANTI_AFFINITY_GROUP"

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

ocaml/xapi/message_forwarding.ml

@@ -416,6 +416,17 @@ functor
           Ref.string_of vm_appliance
       with _ -> "invalid"
 
+    let vm_group_uuid ~__context vm_group =
+      try
+        if Pool_role.is_master () then
+          let name = Db.VM_group.get_name_label ~__context ~self:vm_group in
+          Printf.sprintf "%s%s"
+            (Db.VM_group.get_uuid ~__context ~self:vm_group)
+            (add_brackets name)
+        else
+          Ref.string_of vm_group
+      with _ -> "invalid"
+
     let sr_uuid ~__context sr =
       try
         if Pool_role.is_master () then
@@ -2996,6 +3007,12 @@ functor
           (vm_appliance_uuid ~__context value) ;
         Local.VM.set_appliance ~__context ~self ~value
 
+      let set_groups ~__context ~self ~value =
+        info "VM.set_groups : pool = '%s'; value = [ %s ]"
+          (vm_uuid ~__context self)
+          (String.concat "; " (List.map (vm_group_uuid ~__context) value)) ;
+        Local.VM.set_groups ~__context ~self ~value
+
       let import_convert ~__context ~_type ~username ~password ~sr
           ~remote_config =
         info "VM.import_convert: type = '%s'; remote_config = '%s;'" _type
@@ -6511,6 +6528,20 @@ functor
         )
     end
 
+    module VM_group = struct
+      (* include Local.VM_group *)
+
+      let create ~__context ~name_label ~name_description ~placement =
+        info "VM_group.create: name = '%s'; name_description = '%s'" name_label
+          name_description ;
+        Local.VM_group.create ~__context ~name_label ~name_description
+          ~placement
+
+      let destroy ~__context ~self =
+        info "VM_group.destroy: self = '%s'" (vm_group_uuid ~__context self) ;
+        Local.VM_group.destroy ~__context ~self
+    end
+
     module Observer = struct
       module RefSet = Set.Make (struct
         type t = [`host] Ref.t