CP-17481: is_control_domain =/=> domain zero

The API has always had documentation that allows for more than one VM to
have `is_control_domain = true`:

> field ... "is_control_domain" "true if this is a control domain (domain 0 or a driver domain)";

Most of Xapi has been written with this in mind, e.g. `Xapi_host.destroy`
which iterates through a list, `my_control_domains`.

However there are a few places where it is assumed that dom0 is the only
VM with `is_control_domain = true` and this patch makes these a bit more
sane.

Where the original code assumed only one control domain and did an
operation that only makes sense for domain 0, an additional filter is
applied to only operate on VMs with `domid = 0`. Where the original code
assumed only one control domain and did an operation that makes sense
for all control domains then this has been extended to operate on the
list of VMs with `is_control_domain = true`.

Signed-off-by: Si Beaumont <simon.beaumont@citrix.com>

Author: simonjbeaumont

ocaml/xapi/helpers.ml

@@ -310,7 +310,11 @@ let get_user ~__context username =
         failwith "Failed to find any users";
     List.hd uuids (* FIXME! it assumes that there is only one element in the list (root), username is not used*)
 
-(* Expects only 1 control domain per host; just return first in list for now if multiple.. *)
+let is_domain_zero ~__context vm_ref =
+  Db.VM.get_is_control_domain ~__context ~self:vm_ref
+  && Db.VM.get_domid ~__context ~self:vm_ref = 0L
+
+(* Expects only 1 domain zero per host; just return first in list for now if multiple.. *)
 exception No_domain_zero of string
 let domain_zero_ref_cache = ref None
 let domain_zero_ref_cache_mutex = Mutex.create ()
@@ -324,14 +328,14 @@ let get_domain_zero ~__context : API.ref_VM =
 	 let uuid = Xapi_inventory.lookup Xapi_inventory._control_domain_uuid in
 	 try
 	   let vm = Db.VM.get_by_uuid ~__context ~uuid in
-	   if not (Db.VM.get_is_control_domain ~__context ~self:vm) then begin
-	     error "VM uuid %s is not a control domain but the uuid is in my inventory file" uuid;
+	   if not (is_domain_zero ~__context vm) then begin
+	     error "VM uuid %s is not domain zero but the uuid is in my inventory file" uuid;
 	     raise (No_domain_zero uuid);
 	   end;
 	   domain_zero_ref_cache := Some vm;
 	   vm
 	 with _ ->
-	   error "Failed to find control domain (uuid = %s)" uuid;
+	   error "Failed to find domain zero (uuid = %s)" uuid;
 	   raise (No_domain_zero uuid)
     )
 
@@ -509,21 +513,19 @@ let boot_method_of_vm ~__context ~vm =
 (** Returns true if the supplied VM configuration is HVM.
     NB that just because a VM's current configuration looks like HVM doesn't imply it
     actually booted that way; you must check the boot_record to be sure *)
-let is_hvm (x: API.vM_t) = not(x.API.vM_is_control_domain) && x.API.vM_HVM_boot_policy <> ""
+let is_hvm (x: API.vM_t) = x.API.vM_HVM_boot_policy <> ""
 
 let will_boot_hvm ~__context ~self = Db.VM.get_HVM_boot_policy ~__context ~self <> ""
 
 let has_booted_hvm ~__context ~self =
-  (not (Db.VM.get_is_control_domain ~__context ~self))
-  &&
-    let boot_record = get_boot_record ~__context ~self in
-    boot_record.API.vM_HVM_boot_policy <> ""
+  let boot_record = get_boot_record ~__context ~self in
+  boot_record.API.vM_HVM_boot_policy <> ""
 
 let has_booted_hvm_of_record ~__context r =
-  (not (r.Db_actions.vM_is_control_domain))
-  &&
-    let boot_record = get_boot_record_of_record ~__context ~string:r.Db_actions.vM_last_booted_record ~uuid:r.Db_actions.vM_uuid in
-    boot_record.API.vM_HVM_boot_policy <> ""
+  let boot_record =
+    get_boot_record_of_record ~__context
+      ~string:r.Db_actions.vM_last_booted_record ~uuid:r.Db_actions.vM_uuid in
+  boot_record.API.vM_HVM_boot_policy <> ""
 
 let is_running ~__context ~self = Db.VM.get_domid ~__context ~self <> -1L
 

ocaml/xapi/pool_db_backup.ml

@@ -73,7 +73,7 @@ let prepare_database_for_restore ~old_context ~new_context =
 
 	(* Set the master's dom0 to ours *)
 	let my_control_uuid = Xapi_inventory.lookup Xapi_inventory._control_domain_uuid in
-	begin match List.filter (fun self -> Db.VM.get_is_control_domain ~__context:new_context ~self)
+	begin match List.filter (fun vm -> Helpers.is_domain_zero ~__context:new_context vm)
 		(Db.Host.get_resident_VMs ~__context:new_context ~self:master) with
 			| [ dom0 ] ->
 				Db.VM.set_uuid ~__context:new_context ~self:dom0 ~value:my_control_uuid

ocaml/xapi/quicktest.ml

@@ -717,11 +717,7 @@ let vdi_test session_id =
   debug test (Printf.sprintf "Time to create: %f%!" createtime);
   let pbd = List.hd (Client.SR.get_PBDs !rpc session_id sr) in
   let host = Client.PBD.get_host !rpc session_id pbd in
-  let vms = Client.VM.get_all !rpc session_id in
-  let filter vm =
-    Client.VM.get_is_control_domain !rpc session_id vm &&
-      Client.VM.get_resident_on !rpc session_id vm = host in
-  let dom0 = List.find filter vms in
+  let dom0 = dom0_of_host session_id host in
   let device = List.hd (Client.VM.get_allowed_VBD_devices !rpc session_id dom0) in
   debug test (Printf.sprintf "Creating a VBD connecting the VDI to localhost%!");
   let vbd = Client.VBD.create ~rpc:!rpc ~session_id ~vM:dom0 ~vDI:newvdi ~userdevice:device ~bootable:false
@@ -748,11 +744,7 @@ let async_test session_id =
     "description" sr 4194304L `user false false [] [] [] [] in
   let pbd = List.hd (Client.SR.get_PBDs !rpc session_id sr) in
   let host = Client.PBD.get_host !rpc session_id pbd in
-  let vms = Client.VM.get_all !rpc session_id in
-  let filter vm =
-    Client.VM.get_is_control_domain !rpc session_id vm &&
-      Client.VM.get_resident_on !rpc session_id vm = host in
-  let dom0 = List.find filter vms in
+  let dom0 = dom0_of_host session_id host in
   let device = List.hd (Client.VM.get_allowed_VBD_devices !rpc session_id dom0) in
   let vbd = Client.VBD.create ~rpc:!rpc ~session_id ~vM:dom0 ~vDI:newvdi ~userdevice:device ~bootable:false
     ~mode:`RW ~_type:`Disk ~unpluggable:true ~empty:false ~other_config:[] ~qos_algorithm_type:"" ~qos_algorithm_params:[] in

ocaml/xapi/quicktest_common.ml

@@ -240,3 +240,13 @@ let find_guest_installer_network session_id =
   match List.filter (fun (_, r) -> List.mem_assoc Xapi_globs.is_guest_installer_network r.API.network_other_config) all with
   | (rf, _) :: _ -> rf
   | _ -> failwith "Could not find guest installer network"
+
+(** Return a host's domain zero *)
+let dom0_of_host session_id host =
+  match
+    List.filter (fun vm ->
+      Client.VM.get_is_control_domain !rpc session_id vm
+      && Client.VM.get_domid !rpc session_id vm = 0L
+    ) (Client.Host.get_resident_VMs !rpc session_id host) with
+  | [] -> failwith (Printf.sprintf "Host %s has no running domain zero" (Client.Host.get_uuid !rpc session_id host))
+  | vm :: _ -> vm

ocaml/xapi/quicktest_storage.ml

@@ -73,13 +73,6 @@ let choose_active_pbd session_id sr =
   | [] -> failwith (Printf.sprintf "SR %s has no attached PBDs" (Client.SR.get_uuid !rpc session_id sr))
   | x :: _ -> x
 
-(** Return a host's control domain *)
-let control_domain_of_host session_id host = 
-  match List.filter (fun vm -> Client.VM.get_is_control_domain !rpc session_id vm) 
-  (Client.Host.get_resident_VMs !rpc session_id host) with
-  | [] -> failwith (Printf.sprintf "Host %s has no running control domain" (Client.Host.get_uuid !rpc session_id host))
-  | vm :: _ -> vm
-
 (** Scan an SR and return the number of VDIs contained within *)
 let count_vdis session_id sr = 
   Client.SR.scan !rpc session_id sr;
@@ -181,7 +174,7 @@ let vdi_create_destroy_plug_checksize caps session_id sr =
 
     let plug_in_check_size session_id host vdi = 
       let size_should_be = Client.VDI.get_virtual_size !rpc session_id vdi in
-      let dom0 = control_domain_of_host session_id host in
+      let dom0 = dom0_of_host session_id host in
       let vbd = vbd_create_helper ~session_id ~vM:dom0 ~vDI:vdi () in
       Client.VBD.plug !rpc session_id vbd;
       finally

ocaml/xapi/workload_balancing.ml

@@ -568,8 +568,14 @@ let retrieve_wlb_config ~__context =
   perform_wlb_request ~meth:"GetXenPoolConfiguration" ~params ~handle_response
     ~__context ()
 
-  let get_dom0_vm ~__context host=
-    List.hd (List.filter (fun v -> (Db.VM.get_is_control_domain ~__context ~self:v)) (Db.Host.get_resident_VMs ~__context ~self:(Db.Host.get_by_uuid ~__context ~uuid:host)))
+  let get_dom0_vm ~__context host =
+    let resident_VMs =
+      Db.Host.get_resident_VMs ~__context
+        ~self:(Db.Host.get_by_uuid ~__context ~uuid:host) in
+    List.filter (fun v ->
+      Helpers.is_domain_zero ~__context v
+    ) resident_VMs
+    |> List.hd
 
 let get_opt_recommendations ~__context =
   assert_wlb_enabled ~__context;

ocaml/xapi/xapi_host.ml

@@ -113,12 +113,19 @@ let assert_bacon_mode ~__context ~host =
 		let vm_data = [selfref; "vm"; Ref.string_of (List.hd guest_vms)] in
 		raise (Api_errors.Server_error (Api_errors.host_in_use, vm_data)));
 	debug "Bacon test: VMs OK - %d running VMs" (List.length vms);
-	let controldomain = List.find (fun vm -> Db.VM.get_resident_on ~__context ~self:vm = host &&
-			Db.VM.get_is_control_domain ~__context ~self:vm) (Db.VM.get_all ~__context) in
-	let vbds = List.filter (fun vbd -> Db.VBD.get_VM ~__context ~self:vbd = controldomain &&
-			Db.VBD.get_currently_attached ~__context ~self:vbd) (Db.VBD.get_all ~__context) in
-	if List.length vbds > 0 then
-		raise (Api_errors.Server_error (Api_errors.host_in_use, [ selfref; "vbd"; List.hd (List.map Ref.string_of vbds) ]));
+	let control_domain_vbds =
+		List.filter (fun vm ->
+				Db.VM.get_resident_on ~__context ~self:vm = host
+				&& Db.VM.get_is_control_domain ~__context ~self:vm
+		) (Db.VM.get_all ~__context)
+		|> List.map (fun self -> Db.VM.get_VBDs ~__context ~self)
+		|> List.flatten
+		|> List.filter (fun self -> Db.VBD.get_currently_attached ~__context ~self) in
+	if List.length control_domain_vbds > 0 then
+		raise (Api_errors.Server_error (
+			Api_errors.host_in_use,
+			[ selfref; "vbd"; List.hd (List.map Ref.string_of control_domain_vbds) ]
+		));
 	debug "Bacon test: VBDs OK"
 
 let signal_networking_change ~__context =

ocaml/xapi/xapi_pool.ml

@@ -854,10 +854,10 @@ let eject ~__context ~host =
 		 * rest of the pool. *)
 		Pool_features.update_pool_features ~__context;
 
-		(* and destroy my control domain, since you can't do this from the API [operation not allowed] *)
+		(* and destroy my control domains, since you can't do this from the API [operation not allowed] *)
 		begin try
-			let my_control_domain = List.find (fun x->x.API.vM_is_control_domain) (List.map snd my_vms_with_records) in
-			Db.VM.destroy ~__context ~self:(Db.VM.get_by_uuid ~__context ~uuid:my_control_domain.API.vM_uuid)
+			let my_control_domains = List.filter (fun x->x.API.vM_is_control_domain) (List.map snd my_vms_with_records) in
+			List.iter (fun control_domain -> Db.VM.destroy ~__context ~self:(Db.VM.get_by_uuid ~__context ~uuid:control_domain.API.vM_uuid)) my_control_domains;
 		with _ -> () end;
 		debug "Pool.eject: setting our role to be master";
 		Pool_role.set_role Pool_role.Master;

ocaml/xapi/xapi_vdi_helpers.ml

@@ -37,7 +37,7 @@ let metadata_replication : ((API.ref_VDI, (API.ref_VBD * Redo_log.redo_log)) Has
 let get_master_dom0 ~__context =
 	let master = Helpers.get_master ~__context in
 	let vms = Db.Host.get_resident_VMs ~__context ~self:master in
-	List.hd (List.filter (fun vm -> Db.VM.get_is_control_domain ~__context ~self:vm) vms)
+	List.hd (List.filter (fun vm -> Helpers.is_domain_zero ~__context vm) vms)
 
 (* Unplug and destroy any existing VBDs owned by the VDI. *)
 let destroy_all_vbds ~__context ~vdi =

ocaml/xapi/xapi_vm_lifecycle.ml

@@ -327,7 +327,7 @@ let check_operation_error ~__context ~vmr ~vmgmr ~ref ~clone_suspended_vm_enable
 			&& op <> `metadata_export
 			&& op <> `changing_dynamic_range
 			&& op <> `start
-		then Some (Api_errors.operation_not_allowed, ["Operations on domain 0 are not allowed"])
+		then Some (Api_errors.operation_not_allowed, ["Operations on control domain are not allowed"])
 		else None) in
 
 	(* check for any HVM guest feature needed by the op *)