CP-17481: Allow other VMs to use is_control_domain

ocaml/client_records/records.ml

@@ -1096,6 +1096,7 @@ let host_record rpc session_id host =
 			make_field ~name:"virtual-hardware-platform-versions" 
 				~get:(fun () -> String.concat "; " (List.map Int64.to_string (x ()).API.host_virtual_hardware_platform_versions)) 
 				~get_set:(fun () -> List.map Int64.to_string (x ()).API.host_virtual_hardware_platform_versions) ();
+			make_field ~name:"control-domain-uuid" ~get:(fun () -> get_uuid_from_ref (x ()).API.host_control_domain) ();
 		]}
 
 let vdi_record rpc session_id vdi =

ocaml/idl/datamodel.ml

@@ -4683,6 +4683,7 @@ let host =
 	field ~qualifier:RW ~in_product_since:rel_tampa ~default_value:(Some (VMap [])) ~ty:(Map (String, String)) "guest_VCPUs_params" "VCPUs params to apply to all resident guests";
 	field ~qualifier:RW ~in_product_since:rel_cream ~default_value:(Some (VEnum "enabled")) ~ty:host_display "display" "indicates whether the host is configured to output its console to a physical display device";
 	field ~qualifier:DynamicRO ~in_product_since:rel_cream ~default_value:(Some (VSet [VInt 0L])) ~ty:(Set (Int)) "virtual_hardware_platform_versions" "The set of versions of the virtual hardware platform that the host can offer to its guests";
+	field ~qualifier:DynamicRO ~default_value:(Some (VRef (Ref.string_of Ref.null))) ~in_product_since:rel_dundee_plus ~ty:(Ref _vm) "control_domain" "The control domain (domain 0)";
  ])
 	()
 

ocaml/test/test_common.ml

@@ -60,7 +60,7 @@ let make_localhost ~__context =
 	   simple thing first and just set localhost_ref instead. *)
 	(* Dbsync_slave.refresh_localhost_info ~__context host_info; *)
 	Xapi_globs.localhost_ref := Helpers.get_localhost ~__context;
-	Create_misc.ensure_domain_zero_records ~__context host_info;
+	Create_misc.ensure_domain_zero_records ~__context ~host:!Xapi_globs.localhost_ref host_info;
 	Dbsync_master.create_pool_record ~__context
 
 (** Make a simple in-memory database containing a single host and dom0 VM record. *)

ocaml/test/test_vdi_allowed_operations.ml

@@ -108,7 +108,7 @@ let test_ca101669 () =
 		`copy (Some (Api_errors.vdi_in_use, []))
 
 let test_ca125187 () =
-	let __context = Mock.make_context_with_new_db "Mock context" in
+	let __context = Test_common.make_test_database () in
 
 	(* A VDI being copied can be copied again concurrently. *)
 	run_assert_equal_with_vdi ~__context
@@ -123,9 +123,8 @@ let test_ca125187 () =
 	 * the VBD is plugged after the VDI is marked with the copy operation. *)
 	let _, _ = setup_test ~__context
 		~vdi_fun:(fun vdi_ref ->
-			let vm_ref = make_vm ~__context () in
-			Db.VM.set_is_control_domain ~__context ~self:vm_ref ~value:true;
-			Db.VM.set_power_state ~__context ~self:vm_ref ~value:`Running;
+            let host_ref = Helpers.get_localhost ~__context in
+            let vm_ref = Db.Host.get_control_domain ~__context ~self:host_ref in
 			let vbd_ref = Ref.make () in
 			let (_: API.ref_VBD) = make_vbd ~__context
 				~ref:vbd_ref

ocaml/xapi/create_misc.ml

@@ -133,12 +133,23 @@ let (+++) = Int64.add
 (** This function makes sure there is exactly one record of each type. *)
 (** It updates existing records if they are found, or else creates new *)
 (** records for any records that are missing.                          *)
-let rec ensure_domain_zero_records ~__context (host_info: host_info) : unit =
+let rec ensure_domain_zero_records ~__context ~host (host_info: host_info) : unit =
+	maybe_upgrade_domain_zero_record ~__context ~host host_info;
 	let domain_zero_ref = ensure_domain_zero_record ~__context host_info in
 	ensure_domain_zero_console_record ~__context ~domain_zero_ref;
 	ensure_domain_zero_guest_metrics_record ~__context ~domain_zero_ref host_info;
 	ensure_domain_zero_shadow_record ~__context ~domain_zero_ref
 
+and maybe_upgrade_domain_zero_record ~__context ~host (host_info: host_info) =
+	try
+		let control_domain = Db.VM.get_by_uuid ~__context ~uuid:host_info.dom0_uuid in
+		if Db.Host.get_control_domain ~__context ~self:host = Ref.null then begin
+			debug "Setting control domain for host %s to %s"
+				(Ref.string_of host) (Ref.string_of control_domain);
+			Db.Host.set_control_domain ~__context ~self:host ~value:control_domain;
+		end
+	with Db_exn.Read_missing_uuid(_) -> ()
+
 and ensure_domain_zero_record ~__context (host_info: host_info): [`VM] Ref.t =
 	let ref_lookup () = Helpers.get_domain_zero ~__context in
 	let ref_create () = Ref.make () in
@@ -225,6 +236,7 @@ and create_domain_zero_record ~__context ~domain_zero_ref (host_info: host_info)
 		~hardware_platform_version:0L
 		~has_vendor_device:false
 	;
+	Db.Host.set_control_domain ~__context ~self:localhost ~value:domain_zero_ref;
 	Xapi_vm_helpers.update_memory_overhead ~__context ~vm:domain_zero_ref
 
 and create_domain_zero_console_record_with_protocol ~__context ~domain_zero_ref ~dom0_console_protocol =

ocaml/xapi/create_misc.mli

@@ -32,7 +32,7 @@ type host_info = {
 val read_dom0_memory_usage : unit -> int64 option
 val read_localhost_info : unit -> host_info
 
-val ensure_domain_zero_records : __context:Context.t -> host_info -> unit
+val ensure_domain_zero_records : __context:Context.t -> host:[`host] Ref.t -> host_info -> unit
 
 val create_root_user : __context:Context.t -> unit
 

ocaml/xapi/dbsync_slave.ml

@@ -280,13 +280,13 @@ let update_env __context sync_keys =
     Create_misc.create_host_cpu ~__context;
   );
 
+  let localhost = Helpers.get_localhost ~__context in
+
   switched_sync Xapi_globs.sync_create_domain_zero (fun () ->
     debug "creating domain 0";
-    Create_misc.ensure_domain_zero_records ~__context info;
+    Create_misc.ensure_domain_zero_records ~__context ~host:localhost info;
   );
 
-  let localhost = Helpers.get_localhost ~__context in
-
   switched_sync Xapi_globs.sync_crashdump_resynchronise (fun () ->
     debug "resynchronising host crashdumps";
     Xapi_host_crashdump.resynchronise ~__context ~host:localhost;

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 =
+  let host_ref = Db.VM.get_resident_on ~__context ~self:vm_ref in
+  Db.VM.get_is_control_domain ~__context ~self:vm_ref
+  && Db.Host.get_control_domain ~__context ~self:host_ref = vm_ref
+
 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,23 @@ 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 ~__context (x: API.vM_t) = 
+  let vm_ref = Db.VM.get_by_uuid ~__context ~uuid:x.API.vM_uuid in
+  (not (is_domain_zero ~__context vm_ref)) && 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
+  (not (is_domain_zero ~__context self)) && 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 vm_uuid = r.Db_actions.vM_uuid in
+  let vm_ref = Db.VM.get_by_uuid ~__context ~uuid:vm_uuid in
+  let boot_record =
+    get_boot_record_of_record ~__context
+      ~string:r.Db_actions.vM_last_booted_record ~uuid:vm_uuid in
+  (not (is_domain_zero ~__context vm_ref)) && boot_record.API.vM_HVM_boot_policy <> ""
 
 let is_running ~__context ~self = Db.VM.get_domid ~__context ~self <> -1L
 

ocaml/xapi/import.ml

@@ -410,7 +410,7 @@ module VM : HandlerTools = struct
 					{vm_record with API.vM_has_vendor_device = false;}
 				) in
 			let vm_record = {vm_record with API.
-				vM_memory_overhead = Memory_check.vm_compute_memory_overhead vm_record
+				vM_memory_overhead = Memory_check.vm_compute_memory_overhead ~__context vm_record
 			} in
 			let vm_record = {vm_record with API.vM_protection_policy = Ref.null} in
 			(* Full restore preserves UUIDs, so if we are replacing an existing VM the version number should be incremented *)

ocaml/xapi/memory_check.ml

@@ -21,21 +21,21 @@ let ( /// ) = Int64.div
 
 (** Calculates the amounts of 'normal' and 'shadow' host memory needed *)
 (** to run the given guest with the given amount of guest memory.      *)
-let vm_compute_required_memory vm_record guest_memory_kib =
+let vm_compute_required_memory ~__context vm_record guest_memory_kib =
 	let vcpu_count = Int64.to_int vm_record.API.vM_VCPUs_max in
 	let multiplier =
-		if Helpers.is_hvm vm_record
+		if Helpers.is_hvm ~__context vm_record
 		then vm_record.API.vM_HVM_shadow_multiplier
 		else XenopsMemory.Linux.shadow_multiplier_default in
 	let target_mib = XenopsMemory.mib_of_kib_used guest_memory_kib in
 	let max_mib = XenopsMemory.mib_of_bytes_used vm_record.API.vM_memory_static_max in
 	let footprint_mib = (
-		if Helpers.is_hvm vm_record
+		if Helpers.is_hvm ~__context vm_record
 		then XenopsMemory.HVM.footprint_mib
 		else XenopsMemory.Linux.footprint_mib)
 			target_mib max_mib vcpu_count multiplier in
 	let shadow_mib = (
-		if Helpers.is_hvm vm_record
+		if Helpers.is_hvm ~__context vm_record
 		then XenopsMemory.HVM.shadow_mib
 		else XenopsMemory.Linux.shadow_mib)
 			max_mib vcpu_count multiplier in
@@ -78,7 +78,7 @@ let vm_compute_start_memory ~__context ?(policy=Dynamic_min) vm_record =
 			~memory_dynamic_min: vm_record.API.vM_memory_dynamic_min
 			~memory_dynamic_max: vm_record.API.vM_memory_dynamic_max
 			~memory_static_max:  vm_record.API.vM_memory_static_max in
-		vm_compute_required_memory vm_record
+		vm_compute_required_memory ~__context vm_record
 			(XenopsMemory.kib_of_bytes_used memory_required)
 
 (** Calculates the amount of memory required in both 'normal' and 'shadow'
@@ -101,7 +101,7 @@ let vm_compute_used_memory ~__context policy vm_ref =
 let vm_compute_resume_memory ~__context vm_ref =
 	if Xapi_fist.disable_memory_checks () then 0L else
 	let vm_boot_record = Helpers.get_boot_record ~__context ~self:vm_ref in
-	let (_, shadow_bytes) = vm_compute_required_memory
+	let (_, shadow_bytes) = vm_compute_required_memory ~__context
 		vm_boot_record vm_boot_record.API.vM_memory_static_max in
 	(* CA-31759: use the live target field for this *)
 	(* rather than the LBR to make upgrade easy.    *)
@@ -112,7 +112,7 @@ let vm_compute_resume_memory ~__context vm_ref =
 let vm_compute_migrate_memory ~__context vm_ref =
 	if Xapi_fist.disable_memory_checks () then 0L else
 	let vm_record = Db.VM.get_record ~__context ~self:vm_ref in
-	let (_, shadow_bytes) = vm_compute_required_memory
+	let (_, shadow_bytes) = vm_compute_required_memory ~__context
 		vm_record vm_record.API.vM_memory_static_max in
 	(* Only used when in rolling upgrade mode (from a pre-ballooning product) *)
 	let current_memory_usage_bytes = vm_record.API.vM_memory_static_max in
@@ -243,13 +243,13 @@ let host_compute_memory_overhead ~__context ~host =
 	(* to time and simply fetch the existing cached value from the database. *)
 	Db.Host.get_memory_overhead ~__context ~self:host
 
-let vm_compute_memory_overhead snapshot =
+let vm_compute_memory_overhead ~__context snapshot =
 	let static_max_bytes = snapshot.API.vM_memory_static_max in
 	let static_max_mib = XenopsMemory.mib_of_bytes_used static_max_bytes in
 	let multiplier = snapshot.API.vM_HVM_shadow_multiplier in
 	let vcpu_count = Int64.to_int (snapshot.API.vM_VCPUs_max) in
 	let memory_overhead_mib = (
-		if Helpers.is_hvm snapshot
+		if Helpers.is_hvm ~__context snapshot
 		then XenopsMemory.HVM.overhead_mib
 		else XenopsMemory.Linux.overhead_mib)
 			static_max_mib vcpu_count multiplier in

ocaml/xapi/memory_check.mli

@@ -53,7 +53,7 @@ type accounting_policy =
 val get_host_memory_summary : __context:Context.t -> host:API.ref_host ->
 	host_memory_summary
 
-val vm_compute_required_memory : API.vM_t -> int64 -> int64 * int64
+val vm_compute_required_memory : __context:Context.t -> API.vM_t -> int64 -> int64 * int64
 
 val vm_compute_start_memory : __context:Context.t ->
 	?policy:accounting_policy -> API.vM_t -> int64 * int64
@@ -93,5 +93,5 @@ val host_compute_free_memory_with_maximum_compression : ?dump_stats:bool ->
 val host_compute_memory_overhead : __context:Context.t -> host:[`host] Ref.t ->
 	int64
 
-val vm_compute_memory_overhead : API.vM_t -> int64
+val vm_compute_memory_overhead :  __context:Context.t -> API.vM_t -> int64
 

ocaml/xapi/pool_db_backup.ml

@@ -73,12 +73,8 @@ 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)
-		(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
-			| _ -> error "Failed to set master control domain's uuid"
-	end;
+	let dom0 = Db.Host.get_control_domain ~__context:new_context ~self:master in
+	Db.VM.set_uuid ~__context:new_context ~self:dom0 ~value:my_control_uuid;
 
 	(* Rewrite this host's PIFs' MAC addresses based on device name. *)
 

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,7 @@ 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 =
+  Client.Host.get_control_domain !rpc session_id host

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,8 @@ 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 =
+    Db.Host.get_control_domain ~__context ~self:(Db.Host.get_by_uuid ~__context ~uuid:host)
 
 let get_opt_recommendations ~__context =
   assert_wlb_enabled ~__context;