Merge remote-tracking branch 'xsu/master' into feature/perf-update

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

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

@@ -916,7 +916,10 @@ let _ =
   error Api_errors.wlb_timeout ["configured_timeout"]
     ~doc:"The communication with the WLB server timed out." () ;
   error Api_errors.wlb_authentication_failed []
-    ~doc:"WLB rejected our configured authentication details." () ;
+    ~doc:
+      "Failed to authenticate with the WLB server, the provided credentials \
+       are invalid."
+    () ;
   error Api_errors.wlb_malformed_request []
     ~doc:"WLB rejected the server's request as malformed." () ;
   error Api_errors.wlb_malformed_response
@@ -1963,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:

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

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

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 = "e34cd0d32cdcec7805c2d3ed4e4a0c25"
+let last_known_schema_hash = "efdb1c7e536362523741ccdb7f33f797"
 
 let current_schema_hash : string =
   let open Datamodel_types in

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

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