Merge pull request #5952 from robhoes/startflag

Add feature flags to block starting VMs

ocaml/idl/datamodel_lifecycle.ml

@@ -26,7 +26,7 @@ let prototyped_of_field = function
   | "Observer", "uuid" ->
       Some "23.14.0"
   | "Repository", "origin" ->
-      Some "24.21.0-next"
+      Some "24.23.0"
   | "Repository", "gpgkey_path" ->
       Some "22.12.0"
   | "Certificate", "fingerprint_sha1" ->
@@ -126,7 +126,7 @@ let prototyped_of_message = function
   | "Repository", "set_gpgkey_path" ->
       Some "22.12.0"
   | "Repository", "introduce_bundle" ->
-      Some "24.21.0-next"
+      Some "24.23.0"
   | "PCI", "get_dom0_access_status" ->
       Some "24.14.0"
   | "PCI", "enable_dom0_access" ->

ocaml/tests/test_features.ml

@@ -29,35 +29,46 @@ module OfAssocList = Generic.MakeStateless (struct
 
   let transform = of_assoc_list
 
-  (* Xen_motion and AD are enabled unless explicitly disabled. All other features
-     	   are disabled unless explitly enabled. *)
+  (* Some features are enabled unless explicitly disabled (see `enabled_when_unknown`
+     in features.ml). All other features are disabled unless explitly enabled. *)
   let tests =
     `QuickAndAutoDocumented
       [
-        ([], [Xen_motion; AD; Updates])
+        ([], [Xen_motion; AD; Updates; VM_start; VM_appliance_start])
       ; ( [
             ("restrict_xen_motion", "true")
           ; ("restrict_ad", "true")
           ; ("restrict_updates", "true")
+          ; ("restrict_vm_start", "true")
+          ; ("restrict_vm_appliance_start", "true")
           ]
         , []
         )
-      ; ([("restrict_xen_motion", "true")], [AD; Updates])
-      ; ([("restrict_xen_motion", "false")], [Xen_motion; AD; Updates])
+      ; ( [("restrict_xen_motion", "true")]
+        , [AD; Updates; VM_start; VM_appliance_start]
+        )
+      ; ( [("restrict_xen_motion", "false")]
+        , [Xen_motion; AD; Updates; VM_start; VM_appliance_start]
+        )
       ; ( [("restrict_xen_motion", "false"); ("restrict_dmc", "false")]
-        , [DMC; Xen_motion; AD; Updates]
+        , [DMC; Xen_motion; AD; Updates; VM_start; VM_appliance_start]
         )
       ; ( [
             ("restrict_xen_motion", "false")
           ; ("restrict_ad", "true")
           ; ("restrict_dmc", "false")
           ]
-        , [DMC; Xen_motion; Updates]
+        , [DMC; Xen_motion; Updates; VM_start; VM_appliance_start]
         )
       ; ( [("enable_xha", "true"); ("restrict_xen_motion", "true")]
-        , [HA; AD; Updates]
+        , [HA; AD; Updates; VM_start; VM_appliance_start]
+        )
+      ; ( [("restrict_updates", "true")]
+        , [Xen_motion; AD; VM_start; VM_appliance_start]
+        )
+      ; ( [("restrict_vm_start", "true")]
+        , [Xen_motion; AD; Updates; VM_appliance_start]
         )
-      ; ([("restrict_updates", "true")], [Xen_motion; AD])
       ]
 end)
 

ocaml/xapi-types/features.ml

@@ -65,6 +65,8 @@ type feature =
   | Internal_repo_access
   | VTPM
   | VM_groups
+  | VM_start
+  | VM_appliance_start
 [@@deriving rpc]
 
 type orientation = Positive | Negative
@@ -134,13 +136,16 @@ let keys_of_features =
     )
   ; (VTPM, ("restrict_vtpm", Negative, "VTPM"))
   ; (VM_groups, ("restrict_vm_groups", Negative, "VM_groups"))
+  ; (VM_start, ("restrict_vm_start", Negative, "Start"))
+  ; (VM_appliance_start, ("restrict_vm_appliance_start", Negative, "Start"))
   ]
 
 (* A list of features that must be considered "enabled" by `of_assoc_list`
    if the feature string is missing from the list. These are existing features
    that have been recently restricted, and which we want to remain enabled during
    a rolling pool upgrade. *)
-let enabled_when_unknown = [Xen_motion; AD; Updates]
+let enabled_when_unknown =
+  [Xen_motion; AD; Updates; VM_start; VM_appliance_start]
 
 let name_of_feature f = rpc_of_feature f |> Rpc.string_of_rpc
 

ocaml/xapi-types/features.mli

@@ -73,6 +73,8 @@ type feature =
       (** Enable restriction on repository access to pool members only *)
   | VTPM  (** Support VTPM device required by Win11 guests *)
   | VM_groups  (** Enable use of VM groups *)
+  | VM_start  (** Allow starting of VMs (!) *)
+  | VM_appliance_start  (** Allow starting of VM appliances *)
 
 val feature_of_rpc : Rpc.t -> feature
 (** Convert RPC into {!feature}s *)

ocaml/xapi/message_forwarding.ml

@@ -743,6 +743,7 @@ functor
       let start ~__context ~self ~paused =
         info "VM_appliance.start: VM_appliance = '%s'"
           (vm_appliance_uuid ~__context self) ;
+        Pool_features.assert_enabled ~__context ~f:Features.VM_appliance_start ;
         with_vm_appliance_operation ~__context ~self ~doc:"VM_appliance.start"
           ~op:`start (fun () ->
             Local.VM_appliance.start ~__context ~self ~paused
@@ -1854,6 +1855,7 @@ functor
 
       let start ~__context ~vm ~start_paused ~force =
         info "VM.start: VM = '%s'" (vm_uuid ~__context vm) ;
+        Pool_features.assert_enabled ~__context ~f:Features.VM_start ;
         Xapi_vm_helpers.assert_no_legacy_hardware ~__context ~vm ;
         let local_fn = Local.VM.start ~vm ~start_paused ~force in
         let host =
@@ -2914,6 +2916,8 @@ functor
         info "VM.assert_can_boot_here: VM = '%s'; host = '%s'"
           (vm_uuid ~__context self)
           (host_uuid ~__context host) ;
+        if Db.VM.get_power_state ~__context ~self = `Halted then
+          Pool_features.assert_enabled ~__context ~f:Features.VM_start ;
         Local.VM.assert_can_boot_here ~__context ~self ~host
 
       let retrieve_wlb_recommendations ~__context ~vm =