vm
let boot_vm session_id vm =
- Client.VM.start rpc session_id vm false true
+ Client.VM.start rpc session_id vm false true
let reset_bootloader session_id vm =
Client.VM.set_PV_bootloader rpc session_id vm "pygrub"
let srs, _ = List.split srs in
if srs = [] then
raise (Test_error "No dummy SR found");
-
+
(* Then, find a VM with a VDI on one of these SRs *)
let vdis = List.flatten (List.map (fun sr -> Client.SR.get_VDIs rpc session sr) srs) in
if vdis = [] then
try f ()
with
| Api_errors.Server_error("SR_BACKEND_FAILURE_1", _) ->
- Printf.printf "Received error. Failure is inevitable.\n%!";
- manager.failure ();
+ Printf.printf "Received error. Failure is inevitable.\n%!";
+ manager.failure ();
| _ -> ()
in
-
+
(* start/force_shutdown loop for the VM *)
let rec start_loop n =
Printf.printf "Start/shutdown loop: %d iterations remaining\n%!" n;
if n <> 0 && manager.continue () then begin
with_dummySR_failure
(fun () ->
- debug "%i/%i: Starting VM ..." (number_of_loop - n + 1) number_of_loop;
- Client.VM.start rpc session vm false false;
- Thread.delay 10.;
- debug "%i/%i: Shutdowning VM ..." (number_of_loop - n + 1) number_of_loop;
- Client.VM.hard_shutdown rpc session vm;
- Thread.delay 10.);
+ debug "%i/%i: Starting VM ..." (number_of_loop - n + 1) number_of_loop;
+ Client.VM.start rpc session vm false false;
+ Thread.delay 10.;
+ debug "%i/%i: Shutdowning VM ..." (number_of_loop - n + 1) number_of_loop;
+ Client.VM.hard_shutdown rpc session vm;
+ Thread.delay 10.);
start_loop (n-1)
end else if n = 0 then
manager.success ()
try Client.SR.get_record rpc session_id sr; () with _ -> raise (Multipathrt_exceptions.Test_error (Printf.sprintf "%s does not exist" name))
let make_iscsi rpc session_id iscsi_luns num_vifs sr_disk_size key network =
- let iscsi_iso = match find_iscsi_iso rpc session_id with
- | Some vdi -> vdi
- | None -> failwith "iSCSI VM iso not found" in
- let template = List.hd (Client.VM.get_by_name_label rpc session_id iscsi_vm_template) in
- let newvm = Client.VM.clone rpc session_id template "ISCSI target server" in
- try
- Client.VM.provision rpc session_id newvm;
- let isovbd = Client.VBD.create rpc session_id newvm iscsi_iso "0" true `RO `CD false false [] "" [] in
- let realpool = List.hd (Client.Pool.get_all rpc session_id) in
- let defaultsr = Client.Pool.get_default_SR rpc session_id realpool in
- assert_sr_exists rpc session_id defaultsr "pool's default SR";
-
- for i = 0 to iscsi_luns - 1 do
- let storage_vdi_label = Printf.sprintf "SCSI VDI %d" i in
- let storage_vdi = Client.VDI.create rpc session_id storage_vdi_label "" defaultsr sr_disk_size `user false false [oc_key,key] [] [] [] in
- let userdevice = Printf.sprintf "%d" (i+1) in
- Client.VBD.create rpc session_id newvm storage_vdi userdevice false `RW `Disk false false [] "" []
- done;
-
- Client.VM.set_PV_bootloader rpc session_id newvm "pygrub";
- Client.VM.set_HVM_boot_policy rpc session_id newvm "";
-
- for i = 0 to num_vifs - 1 do
- ignore (Client.VIF.create rpc session_id (string_of_int i) network newvm "" 1500L [oc_key,key] "" [])
- done;
+ let iscsi_iso = match find_iscsi_iso rpc session_id with
+ | Some vdi -> vdi
+ | None -> failwith "iSCSI VM iso not found" in
+ let template = List.hd (Client.VM.get_by_name_label rpc session_id iscsi_vm_template) in
+ let newvm = Client.VM.clone rpc session_id template "ISCSI target server" in
+ try
+ Client.VM.provision rpc session_id newvm;
+ let isovbd = Client.VBD.create rpc session_id newvm iscsi_iso "0" true `RO `CD false false [] "" [] in
+ let realpool = List.hd (Client.Pool.get_all rpc session_id) in
+ let defaultsr = Client.Pool.get_default_SR rpc session_id realpool in
+ assert_sr_exists rpc session_id defaultsr "pool's default SR";
+
+ for i = 0 to iscsi_luns - 1 do
+ let storage_vdi_label = Printf.sprintf "SCSI VDI %d" i in
+ let storage_vdi = Client.VDI.create rpc session_id storage_vdi_label "" defaultsr sr_disk_size `user false false [oc_key,key] [] [] [] in
+ let userdevice = Printf.sprintf "%d" (i+1) in
+ Client.VBD.create rpc session_id newvm storage_vdi userdevice false `RW `Disk false false [] "" []
+ done;
+
+ Client.VM.set_PV_bootloader rpc session_id newvm "pygrub";
+ Client.VM.set_HVM_boot_policy rpc session_id newvm "";
+
+ for i = 0 to num_vifs - 1 do
+ ignore (Client.VIF.create rpc session_id (string_of_int i) network newvm "" 1500L [oc_key,key] "" [])
+ done;
+
+ Client.VM.add_to_other_config rpc session_id newvm oc_key key;
+ Client.VM.start rpc session_id newvm false false;
+ newvm
+ with e ->
+ debug "Caught exception with iscsi VM: %s" (Printexc.to_string e);
+ debug "Trying to clean up iscsi VM...";
+ (try Client.VM.destroy rpc session_id newvm with _ -> ());
+ raise e
- Client.VM.add_to_other_config rpc session_id newvm oc_key key;
- Client.VM.start rpc session_id newvm false false;
- newvm
- with e ->
- debug "Caught exception with iscsi VM: %s" (Printexc.to_string e);
- debug "Trying to clean up iscsi VM...";
- (try Client.VM.destroy rpc session_id newvm with _ -> ());
- raise e
-
(* --------------- iSCSI SR probe helper functions --------------- *)
(* Copied and pasted from perftest/perfutil.ml *)
(** Create the VM with the iscsi iso attached *)
let make_iscsi session_id pool network =
- try
- let iscsi_iso = match find_iscsi_iso session_id with
- | Some vdi -> vdi
- | None -> failwith "iSCSI VM iso not found" in
- let template = List.hd (Client.VM.get_by_name_label rpc session_id iscsi_vm_template) in
- let newvm = Client.VM.clone rpc session_id template "ISCSI target server" in
- Client.VM.provision rpc session_id newvm;
- let _ (* isovbd *) = Client.VBD.create rpc session_id newvm iscsi_iso "0" true `RO `CD false false [] "" [] in
- let realpool = List.hd (Client.Pool.get_all rpc session_id) in
- let defaultsr = Client.Pool.get_default_SR rpc session_id realpool in
+ try
+ let iscsi_iso = match find_iscsi_iso session_id with
+ | Some vdi -> vdi
+ | None -> failwith "iSCSI VM iso not found" in
+ let template = List.hd (Client.VM.get_by_name_label rpc session_id iscsi_vm_template) in
+ let newvm = Client.VM.clone rpc session_id template "ISCSI target server" in
+ Client.VM.provision rpc session_id newvm;
+ let _ (* isovbd *) = Client.VBD.create rpc session_id newvm iscsi_iso "0" true `RO `CD false false [] "" [] in
+ let realpool = List.hd (Client.Pool.get_all rpc session_id) in
+ let defaultsr = Client.Pool.get_default_SR rpc session_id realpool in
- for i = 0 to pool.iscsi_luns - 1 do
- let storage_vdi_label = Printf.sprintf "SCSI VDI %d" i in
- let storage_vdi = Client.VDI.create rpc session_id storage_vdi_label "" defaultsr sr_disk_size `user false false [oc_key,pool.key] [] [] [] in
- let userdevice = Printf.sprintf "%d" (i+1) in
- ignore(Client.VBD.create rpc session_id newvm storage_vdi userdevice false `RW `Disk false false [] "" [])
- done;
+ for i = 0 to pool.iscsi_luns - 1 do
+ let storage_vdi_label = Printf.sprintf "SCSI VDI %d" i in
+ let storage_vdi = Client.VDI.create rpc session_id storage_vdi_label "" defaultsr sr_disk_size `user false false [oc_key,pool.key] [] [] [] in
+ let userdevice = Printf.sprintf "%d" (i+1) in
+ ignore(Client.VBD.create rpc session_id newvm storage_vdi userdevice false `RW `Disk false false [] "" [])
+ done;
- Client.VM.set_PV_bootloader rpc session_id newvm "pygrub";
- Client.VM.set_PV_args rpc session_id newvm (Printf.sprintf "net_ip=%s net_mask=255.255.255.0" (make_iscsi_ip pool));
- Client.VM.set_HVM_boot_policy rpc session_id newvm "";
- Client.VIF.create rpc session_id "0" network newvm "" 1500L [oc_key,pool.key] "" [];
- Client.VM.add_to_other_config rpc session_id newvm oc_key pool.key;
- let localhost_uuid = Xapi_inventory.lookup "INSTALLATION_UUID" in
- Client.VM.start_on rpc session_id newvm (Client.Host.get_by_uuid rpc session_id localhost_uuid) false false;
- Some newvm
- with e ->
- debug "Caught exception with iscsi VM: %s" (Printexc.to_string e);
- None
+ Client.VM.set_PV_bootloader rpc session_id newvm "pygrub";
+ Client.VM.set_PV_args rpc session_id newvm (Printf.sprintf "net_ip=%s net_mask=255.255.255.0" (make_iscsi_ip pool));
+ Client.VM.set_HVM_boot_policy rpc session_id newvm "";
+ Client.VIF.create rpc session_id "0" network newvm "" 1500L [oc_key,pool.key] "" [];
+ Client.VM.add_to_other_config rpc session_id newvm oc_key pool.key;
+ let localhost_uuid = Xapi_inventory.lookup "INSTALLATION_UUID" in
+ Client.VM.start_on rpc session_id newvm (Client.Host.get_by_uuid rpc session_id localhost_uuid) false false;
+ Some newvm
+ with e ->
+ debug "Caught exception with iscsi VM: %s" (Printexc.to_string e);
+ None
let make ~rpc ~session_id ~pool ~vm ~networks ~storages =
let wintemplate = List.hd (Client.VM.get_by_name_label ~rpc ~session_id ~label:innertemplate) in
then failwith (Printf.sprintf "The iSCSI target VM iso could not be found (%s)" CreateVM.iscsi_vm_iso)
let create_sdk_pool session_id sdkname pool_name key ipbase =
- iscsi_vm_iso_must_exist session_id;
- default_sr_must_be_suitable session_id;
- let pool = List.find (fun p -> p.id = pool_name) pools in
- let pool = {pool with key=key; ipbase=ipbase} in
+ iscsi_vm_iso_must_exist session_id;
+ default_sr_must_be_suitable session_id;
+ let pool = List.find (fun p -> p.id = pool_name) pools in
+ let pool = {pool with key=key; ipbase=ipbase} in
- let template =
- try List.hd (Client.VM.get_by_name_label rpc session_id sdkname)
- with _ -> debug ~out:stderr "template '%s' not found" sdkname; exit 1
- in
- let uuid = Client.VM.get_uuid rpc session_id template in
- debug "Creating test pool '%s' using SDK template uuid=%s" pool.id uuid;
-
- (* Clear up any leftover state on the template *)
- reset_template session_id template;
-
- let interfaces = initialise session_id template pool in
-
- Printf.printf "Creating iSCSI target VM serving %d LUNs\n%!" pool.iscsi_luns;
- let iscsi_vm = CreateVM.make_iscsi session_id pool (Client.VIF.get_network rpc session_id interfaces.(2)) in
-
- debug "Creating %d SDK VMs" pool.hosts;
- let hosts = Array.init pool.hosts (
- fun i ->
- let n = i + 1 in
- let vm = Client.VM.clone rpc session_id template (Printf.sprintf "perftestpool%d" n) in
- Client.VM.provision rpc session_id vm;
- Array.iteri (fun i _ ->
- ignore(Client.VM.add_to_xenstore_data rpc session_id vm (Printf.sprintf "vm-data/provision/interfaces/%d/ip" i)
- (Printf.sprintf "192.168.%d.%d" (i+pool.ipbase) n))) interfaces;
- vm)
- in
+ let template =
+ try List.hd (Client.VM.get_by_name_label rpc session_id sdkname)
+ with _ -> debug ~out:stderr "template '%s' not found" sdkname; exit 1
+ in
+ let uuid = Client.VM.get_uuid rpc session_id template in
+ debug "Creating test pool '%s' using SDK template uuid=%s" pool.id uuid;
+
+ (* Clear up any leftover state on the template *)
+ reset_template session_id template;
+
+ let interfaces = initialise session_id template pool in
+
+ Printf.printf "Creating iSCSI target VM serving %d LUNs\n%!" pool.iscsi_luns;
+ let iscsi_vm = CreateVM.make_iscsi session_id pool (Client.VIF.get_network rpc session_id interfaces.(2)) in
+
+ debug "Creating %d SDK VMs" pool.hosts;
+ let hosts = Array.init pool.hosts (
+ fun i ->
+ let n = i + 1 in
+ let vm = Client.VM.clone rpc session_id template (Printf.sprintf "perftestpool%d" n) in
+ Client.VM.provision rpc session_id vm;
+ Array.iteri (fun i _ ->
+ ignore(Client.VM.add_to_xenstore_data rpc session_id vm (Printf.sprintf "vm-data/provision/interfaces/%d/ip" i)
+ (Printf.sprintf "192.168.%d.%d" (i+pool.ipbase) n))) interfaces;
+ vm)
+ in
- debug "Setting memory on master to be 256 Megs";
- Client.VM.set_memory_static_max rpc session_id hosts.(0) (Int64.mul 256L 1048576L);
- Client.VM.set_memory_static_min rpc session_id hosts.(0) (Int64.mul 256L 1048576L);
- Client.VM.set_memory_dynamic_max rpc session_id hosts.(0) (Int64.mul 256L 1048576L);
- Client.VM.set_memory_dynamic_min rpc session_id hosts.(0) (Int64.mul 256L 1048576L);
-
- Client.VM.add_to_other_config rpc session_id hosts.(0) master_of_pool pool.key;
- Client.VM.add_to_other_config rpc session_id hosts.(0) management_ip (Printf.sprintf "192.168.%d.1" pool.ipbase);
-
- let localhost_uuid = Xapi_inventory.lookup "INSTALLATION_UUID" in
- Array.iteri (fun i host -> debug "Starting VM %d" i; Client.VM.start_on rpc session_id host (Client.Host.get_by_uuid rpc session_id localhost_uuid) false false) hosts;
-
- ignore(Sys.command (Printf.sprintf "ifconfig %s 192.168.%d.200 up" (Client.Network.get_bridge rpc session_id (Client.VIF.get_network rpc session_id interfaces.(0))) pool.ipbase));
-
- reset_template session_id template;
-
- debug "Guests are now booting...";
- let pingable = Array.make (Array.length hosts) false in
- let firstboot = Array.make (Array.length hosts) false in
- let string_of_status () =
- String.implode
- (Array.to_list
- (Array.mapi (fun i ping ->
- let boot = firstboot.(i) in match ping, boot with
- | false, false -> '.'
- | true, false -> 'P'
- | true, true -> 'B'
- | _, _ -> '?') pingable)) in
-
- let has_guest_booted i vm =
- let ip = Printf.sprintf "192.168.%d.%d" pool.ipbase (i+1) in
- let is_pingable () =
- if pingable.(i) then true else begin
- if Sys.command (Printf.sprintf "ping -W 1 -c 1 %s 2>/dev/null >/dev/null" ip) = 0 then begin
- pingable.(i) <- true;
- debug "Individual host status: %s" (string_of_status ());
- true
- end else false
- end in
- let firstbooted () =
- if firstboot.(i) then true else begin
- let rpc = remoterpc ip in
- try
- let s = Client.Session.login_with_password rpc "root" "xensource" "1.1" in
- finally
- (fun () ->
- let host = List.hd (Client.Host.get_all rpc s) in (* only one host because it hasn't joined the pool yet *)
- let other_config = Client.Host.get_other_config rpc s host in
- let key = "firstboot-complete" in
- (* Since these are 'fresh' hosts which have never booted, the key goes from missing -> present *)
- if List.mem_assoc key other_config then begin
- firstboot.(i) <- true;
- debug "Individual host status: %s" (string_of_status ());
- true;
- end else false
- )
- (fun () -> Client.Session.logout rpc s)
- with _ -> false
- end in
- is_pingable () && (firstbooted ()) in
-
- let wait_until_guests_have_booted () =
- for i = 0 to Array.length pingable - 1 do
- pingable.(i) <- false;
- done;
- let finished = ref false in
- while not !finished do
- finished := List.fold_left (&&) true (Array.to_list (Array.mapi has_guest_booted hosts));
- Unix.sleep 20;
- done in
-
- wait_until_guests_have_booted ();
- debug "Guests have booted; issuing Pool.joins.";
-
- let host_uuids = Array.mapi (fun i vm ->
- let n = i + 1 in
- let rpc = remoterpc (Printf.sprintf "192.168.%d.%d" pool.ipbase n) in
- let s = Client.Session.login_with_password rpc "root" "xensource" "1.1" in
- let h = List.hd (Client.Host.get_all rpc s) in
- let u = Client.Host.get_uuid rpc s h in
- debug "Setting name of host %d" n;
- Client.Host.set_name_label rpc s h (Printf.sprintf "perftest host %d" i);
- if i<>0 then begin
- debug "Joining to pool";
- Client.Pool.join rpc s (Printf.sprintf "192.168.%d.1" pool.ipbase) "root" "xensource"
- end;
- u
- ) hosts in
-
- let poolrpc = remoterpc (Printf.sprintf "192.168.%d.1" pool.ipbase) in
- let poolses = Client.Session.login_with_password poolrpc "root" "xensource" "1.1" in
-
- let vpool=List.hd (Client.Pool.get_all poolrpc poolses) in
- Client.Pool.add_to_other_config poolrpc poolses vpool "scenario" pool_name;
-
- debug "Waiting for all hosts to become live and enabled";
- let hosts = Array.of_list (Client.Host.get_all poolrpc poolses) in
- let live = Array.make (Array.length hosts) false in
- let enabled = Array.make (Array.length hosts) false in
- let string_of_status () =
- String.implode
- (Array.to_list
- (Array.mapi (fun i live ->
- let enabled = enabled.(i) in match live, enabled with
- | false, false -> '.'
- | true, false -> 'L'
- | true, true -> 'E'
- | _, _ -> '?') live)) in
-
- let has_host_booted rpc session_id i host =
- try
- if live.(i) && enabled.(i) then true else begin
- let metrics = Client.Host.get_metrics rpc session_id host in
- let live' = Client.Host_metrics.get_live rpc session_id metrics in
- let enabled' = Client.Host.get_enabled rpc session_id host in
- if live.(i) <> live' || enabled.(i) <> enabled' then debug "Individual host status: %s" (string_of_status ());
- live.(i) <- live';
- enabled.(i) <- enabled';
- live' && enabled'
- end
- with _ -> false in
- let finished = ref false in
- while not !finished do
- Unix.sleep 20;
- finished := List.fold_left (&&) true (Array.to_list (Array.mapi (has_host_booted poolrpc poolses) hosts));
- done;
- debug "All hosts are ready.";
-
- let mypool = List.hd (Client.Pool.get_all poolrpc poolses) in
- let master = Client.Pool.get_master poolrpc poolses mypool in
-
- let iscsi_vm_ip = CreateVM.make_iscsi_ip pool in
-
- let xml = try
- Client.SR.probe ~rpc:poolrpc ~session_id:poolses ~host:master
- ~device_config:["target",iscsi_vm_ip]
- ~sm_config:[]
- ~_type:"lvmoiscsi"
- with Api_errors.Server_error("SR_BACKEND_FAILURE_96",[a;b;xml]) ->
- xml
- in
- let iqns = parse_sr_probe_for_iqn xml in
- if iqns = [] then failwith "iSCSI target VM failed again - maybe you should fix it this time?";
- let iqn = List.hd iqns in
- let xml = try
- Client.SR.probe ~rpc:poolrpc ~session_id:poolses ~host:master
- ~device_config:["target",iscsi_vm_ip; "targetIQN",iqn]
- ~sm_config:[]
- ~_type:"lvmoiscsi"
- with Api_errors.Server_error("SR_BACKEND_FAILURE_107",[a;b;xml]) ->
- xml
- in
+ debug "Setting memory on master to be 256 Megs";
+ Client.VM.set_memory_static_max rpc session_id hosts.(0) (Int64.mul 256L 1048576L);
+ Client.VM.set_memory_static_min rpc session_id hosts.(0) (Int64.mul 256L 1048576L);
+ Client.VM.set_memory_dynamic_max rpc session_id hosts.(0) (Int64.mul 256L 1048576L);
+ Client.VM.set_memory_dynamic_min rpc session_id hosts.(0) (Int64.mul 256L 1048576L);
+
+ Client.VM.add_to_other_config rpc session_id hosts.(0) master_of_pool pool.key;
+ Client.VM.add_to_other_config rpc session_id hosts.(0) management_ip (Printf.sprintf "192.168.%d.1" pool.ipbase);
+
+ let localhost_uuid = Xapi_inventory.lookup "INSTALLATION_UUID" in
+ Array.iteri (fun i host -> debug "Starting VM %d" i; Client.VM.start_on rpc session_id host (Client.Host.get_by_uuid rpc session_id localhost_uuid) false false) hosts;
+
+ ignore(Sys.command (Printf.sprintf "ifconfig %s 192.168.%d.200 up" (Client.Network.get_bridge rpc session_id (Client.VIF.get_network rpc session_id interfaces.(0))) pool.ipbase));
+
+ reset_template session_id template;
+
+ debug "Guests are now booting...";
+ let pingable = Array.make (Array.length hosts) false in
+ let firstboot = Array.make (Array.length hosts) false in
+ let string_of_status () =
+ String.implode
+ (Array.to_list
+ (Array.mapi (fun i ping ->
+ let boot = firstboot.(i) in match ping, boot with
+ | false, false -> '.'
+ | true, false -> 'P'
+ | true, true -> 'B'
+ | _, _ -> '?') pingable)) in
+
+ let has_guest_booted i vm =
+ let ip = Printf.sprintf "192.168.%d.%d" pool.ipbase (i+1) in
+ let is_pingable () =
+ if pingable.(i) then true else begin
+ if Sys.command (Printf.sprintf "ping -W 1 -c 1 %s 2>/dev/null >/dev/null" ip) = 0 then begin
+ pingable.(i) <- true;
+ debug "Individual host status: %s" (string_of_status ());
+ true
+ end else false
+ end in
+ let firstbooted () =
+ if firstboot.(i) then true else begin
+ let rpc = remoterpc ip in
+ try
+ let s = Client.Session.login_with_password rpc "root" "xensource" "1.1" in
+ finally
+ (fun () ->
+ let host = List.hd (Client.Host.get_all rpc s) in (* only one host because it hasn't joined the pool yet *)
+ let other_config = Client.Host.get_other_config rpc s host in
+ let key = "firstboot-complete" in
+ (* Since these are 'fresh' hosts which have never booted, the key goes from missing -> present *)
+ if List.mem_assoc key other_config then begin
+ firstboot.(i) <- true;
+ debug "Individual host status: %s" (string_of_status ());
+ true;
+ end else false
+ )
+ (fun () -> Client.Session.logout rpc s)
+ with _ -> false
+ end in
+ is_pingable () && (firstbooted ()) in
+
+ let wait_until_guests_have_booted () =
+ for i = 0 to Array.length pingable - 1 do
+ pingable.(i) <- false;
+ done;
+ let finished = ref false in
+ while not !finished do
+ finished := List.fold_left (&&) true (Array.to_list (Array.mapi has_guest_booted hosts));
+ Unix.sleep 20;
+ done in
- (* Create an SR for each LUN found *)
- Printf.printf "Creating LVMoISCSI SRs (one for each of %d LUNs)\n%!" pool.iscsi_luns;
- let scsiids = Array.of_list (parse_sr_probe_for_scsiids xml) in
- if Array.length scsiids <> pool.iscsi_luns then failwith (Printf.sprintf "We created %d VDIs on the iSCSI target VM but found %d LUNs" pool.iscsi_luns (Array.length scsiids));
- let lun_srs = Array.init pool.iscsi_luns
- (fun i ->
- Printf.printf " - Creating shared LVMoISCSI SR %d...\n%!" i;
- let name_label = Printf.sprintf "LVMoISCSI-%d" i in
- Client.SR.create poolrpc poolses master ["target",iscsi_vm_ip; "targetIQN",iqn; "SCSIid",scsiids.(i)]
- 0L name_label "" "lvmoiscsi" "" true [])
- in
+ wait_until_guests_have_booted ();
+ debug "Guests have booted; issuing Pool.joins.";
+
+ let host_uuids = Array.mapi (fun i vm ->
+ let n = i + 1 in
+ let rpc = remoterpc (Printf.sprintf "192.168.%d.%d" pool.ipbase n) in
+ let s = Client.Session.login_with_password rpc "root" "xensource" "1.1" in
+ let h = List.hd (Client.Host.get_all rpc s) in
+ let u = Client.Host.get_uuid rpc s h in
+ debug "Setting name of host %d" n;
+ Client.Host.set_name_label rpc s h (Printf.sprintf "perftest host %d" i);
+ if i<>0 then begin
+ debug "Joining to pool";
+ Client.Pool.join rpc s (Printf.sprintf "192.168.%d.1" pool.ipbase) "root" "xensource"
+ end;
+ u
+ ) hosts in
+
+ let poolrpc = remoterpc (Printf.sprintf "192.168.%d.1" pool.ipbase) in
+ let poolses = Client.Session.login_with_password poolrpc "root" "xensource" "1.1" in
+
+ let vpool=List.hd (Client.Pool.get_all poolrpc poolses) in
+ Client.Pool.add_to_other_config poolrpc poolses vpool "scenario" pool_name;
+
+ debug "Waiting for all hosts to become live and enabled";
+ let hosts = Array.of_list (Client.Host.get_all poolrpc poolses) in
+ let live = Array.make (Array.length hosts) false in
+ let enabled = Array.make (Array.length hosts) false in
+ let string_of_status () =
+ String.implode
+ (Array.to_list
+ (Array.mapi (fun i live ->
+ let enabled = enabled.(i) in match live, enabled with
+ | false, false -> '.'
+ | true, false -> 'L'
+ | true, true -> 'E'
+ | _, _ -> '?') live)) in
+
+ let has_host_booted rpc session_id i host =
+ try
+ if live.(i) && enabled.(i) then true else begin
+ let metrics = Client.Host.get_metrics rpc session_id host in
+ let live' = Client.Host_metrics.get_live rpc session_id metrics in
+ let enabled' = Client.Host.get_enabled rpc session_id host in
+ if live.(i) <> live' || enabled.(i) <> enabled' then debug "Individual host status: %s" (string_of_status ());
+ live.(i) <- live';
+ enabled.(i) <- enabled';
+ live' && enabled'
+ end
+ with _ -> false in
+ let finished = ref false in
+ while not !finished do
+ Unix.sleep 20;
+ finished := List.fold_left (&&) true (Array.to_list (Array.mapi (has_host_booted poolrpc poolses) hosts));
+ done;
+ debug "All hosts are ready.";
+
+ let mypool = List.hd (Client.Pool.get_all poolrpc poolses) in
+ let master = Client.Pool.get_master poolrpc poolses mypool in
+
+ let iscsi_vm_ip = CreateVM.make_iscsi_ip pool in
+
+ let xml = try
+ Client.SR.probe ~rpc:poolrpc ~session_id:poolses ~host:master
+ ~device_config:["target",iscsi_vm_ip]
+ ~sm_config:[]
+ ~_type:"lvmoiscsi"
+ with Api_errors.Server_error("SR_BACKEND_FAILURE_96",[a;b;xml]) ->
+ xml
+ in
+ let iqns = parse_sr_probe_for_iqn xml in
+ if iqns = [] then failwith "iSCSI target VM failed again - maybe you should fix it this time?";
+ let iqn = List.hd iqns in
+ let xml = try
+ Client.SR.probe ~rpc:poolrpc ~session_id:poolses ~host:master
+ ~device_config:["target",iscsi_vm_ip; "targetIQN",iqn]
+ ~sm_config:[]
+ ~_type:"lvmoiscsi"
+ with Api_errors.Server_error("SR_BACKEND_FAILURE_107",[a;b;xml]) ->
+ xml
+ in
- let local_srs = Array.mapi (fun i host_uuid ->
- let h = Client.Host.get_by_uuid poolrpc poolses host_uuid in
- let name_label = Printf.sprintf "Local LVM on host %d" i in
- Client.SR.create poolrpc poolses h ["device","/dev/"^sr_disk_device] 0L name_label "" "lvm" "" false []) host_uuids
- in
+ (* Create an SR for each LUN found *)
+ Printf.printf "Creating LVMoISCSI SRs (one for each of %d LUNs)\n%!" pool.iscsi_luns;
+ let scsiids = Array.of_list (parse_sr_probe_for_scsiids xml) in
+ if Array.length scsiids <> pool.iscsi_luns then failwith (Printf.sprintf "We created %d VDIs on the iSCSI target VM but found %d LUNs" pool.iscsi_luns (Array.length scsiids));
+ let lun_srs = Array.init pool.iscsi_luns
+ (fun i ->
+ Printf.printf " - Creating shared LVMoISCSI SR %d...\n%!" i;
+ let name_label = Printf.sprintf "LVMoISCSI-%d" i in
+ Client.SR.create poolrpc poolses master ["target",iscsi_vm_ip; "targetIQN",iqn; "SCSIid",scsiids.(i)]
+ 0L name_label "" "lvmoiscsi" "" true [])
+ in
- let pifs = Client.PIF.get_all poolrpc poolses in
+ let local_srs = Array.mapi (fun i host_uuid ->
+ let h = Client.Host.get_by_uuid poolrpc poolses host_uuid in
+ let name_label = Printf.sprintf "Local LVM on host %d" i in
+ Client.SR.create poolrpc poolses h ["device","/dev/"^sr_disk_device] 0L name_label "" "lvm" "" false []) host_uuids
+ in
- let bondednets = Array.init pool.bonds (fun i ->
- Client.Network.create poolrpc poolses (Printf.sprintf "Network associated with bond%d" i) "" 1500L [] [])
- in
+ let pifs = Client.PIF.get_all poolrpc poolses in
- let unused_nets = ref (List.setify (List.map (fun pif -> Client.PIF.get_network poolrpc poolses pif) pifs)) in
-
- (* Reconfigure the master's networking last as this will be the most destructive *)
- let master_uuid = Client.Host.get_uuid poolrpc poolses master in
- let slave_uuids = List.filter (fun x -> x <> master_uuid) (Array.to_list host_uuids) in
- let host_uuids = Array.of_list (slave_uuids @ [ master_uuid ]) in
-
- let bonds = Array.mapi (fun i host_uuid ->
- let host_ref = Client.Host.get_by_uuid poolrpc poolses host_uuid in
- let pifs = List.filter (fun pif -> Client.PIF.get_host poolrpc poolses pif = host_ref) pifs in
- Array.init pool.bonds (fun bnum ->
- let device = Printf.sprintf "eth%d" (bnum*2) in
- let device2 = Printf.sprintf "eth%d" (bnum*2 + 1) in
- let master = List.find (fun pif -> Client.PIF.get_device poolrpc poolses pif = device) pifs in
- let pifs = List.filter (fun pif -> let d = Client.PIF.get_device poolrpc poolses pif in d=device || d=device2) pifs in
- let nets = List.map (fun pif -> Client.PIF.get_network poolrpc poolses pif) pifs in
- unused_nets := List.filter (fun net -> not (List.mem net nets)) !unused_nets;
- let mac = Client.PIF.get_MAC poolrpc poolses master in
- let bond = Client.Bond.create poolrpc poolses bondednets.(bnum) pifs mac in
- let bondpif = Client.Bond.get_master poolrpc poolses bond in
- Client.PIF.reconfigure_ip poolrpc poolses bondpif `Static (Client.PIF.get_IP poolrpc poolses master) "255.255.255.0" "" "";
- if Client.PIF.get_management poolrpc poolses master then begin
- (try Client.Host.management_reconfigure poolrpc poolses bondpif;
- with _ -> ());
- debug "Reconfigured management interface to be on the bond.";
- (* In case we've lost our network connection *)
+ let bondednets = Array.init pool.bonds (fun i ->
+ Client.Network.create poolrpc poolses (Printf.sprintf "Network associated with bond%d" i) "" 1500L [] [])
+ in
+
+ let unused_nets = ref (List.setify (List.map (fun pif -> Client.PIF.get_network poolrpc poolses pif) pifs)) in
+
+ (* Reconfigure the master's networking last as this will be the most destructive *)
+ let master_uuid = Client.Host.get_uuid poolrpc poolses master in
+ let slave_uuids = List.filter (fun x -> x <> master_uuid) (Array.to_list host_uuids) in
+ let host_uuids = Array.of_list (slave_uuids @ [ master_uuid ]) in
+
+ let bonds = Array.mapi (fun i host_uuid ->
+ let host_ref = Client.Host.get_by_uuid poolrpc poolses host_uuid in
+ let pifs = List.filter (fun pif -> Client.PIF.get_host poolrpc poolses pif = host_ref) pifs in
+ Array.init pool.bonds (fun bnum ->
+ let device = Printf.sprintf "eth%d" (bnum*2) in
+ let device2 = Printf.sprintf "eth%d" (bnum*2 + 1) in
+ let master = List.find (fun pif -> Client.PIF.get_device poolrpc poolses pif = device) pifs in
+ let pifs = List.filter (fun pif -> let d = Client.PIF.get_device poolrpc poolses pif in d=device || d=device2) pifs in
+ let nets = List.map (fun pif -> Client.PIF.get_network poolrpc poolses pif) pifs in
+ unused_nets := List.filter (fun net -> not (List.mem net nets)) !unused_nets;
+ let mac = Client.PIF.get_MAC poolrpc poolses master in
+ let bond = Client.Bond.create poolrpc poolses bondednets.(bnum) pifs mac in
+ let bondpif = Client.Bond.get_master poolrpc poolses bond in
+ Client.PIF.reconfigure_ip poolrpc poolses bondpif `Static (Client.PIF.get_IP poolrpc poolses master) "255.255.255.0" "" "";
+ if Client.PIF.get_management poolrpc poolses master then begin
+ (try Client.Host.management_reconfigure poolrpc poolses bondpif;
+ with _ -> ());
+ debug "Reconfigured management interface to be on the bond.";
+ (* In case we've lost our network connection *)
+ wait_until_guests_have_booted ();
+ end;
+ bond
+ )
+ ) host_uuids in
+ debug "Waiting for all guests to be pingable again.";
wait_until_guests_have_booted ();
- end;
- bond
- )
- ) host_uuids in
- debug "Waiting for all guests to be pingable again.";
- wait_until_guests_have_booted ();
- debug "Successfully pinged all virtual hosts.";
- (* We'll use the Windows XP SP3 template to create the VMs required *)
-
- let nets_for_vms = !unused_nets @ (Array.to_list bondednets) in
-
- debug "Nets for VMs: %s" (String.concat "," (List.map (fun net -> Client.Network.get_name_label poolrpc poolses net) nets_for_vms));
-
- let networks = Array.of_list nets_for_vms in
-
- Printf.printf "Creating VMs (%s)\n%!" (if pool.use_shared_storage then "on shared storage" else "on local storage");
- let storages = if pool.use_shared_storage then lun_srs else local_srs in
- List.iter (fun vm -> CreateVM.make ~rpc:poolrpc ~session_id:poolses ~networks ~storages ~pool ~vm) pool.vms
+ debug "Successfully pinged all virtual hosts.";
+ (* We'll use the Windows XP SP3 template to create the VMs required *)
+
+ let nets_for_vms = !unused_nets @ (Array.to_list bondednets) in
+
+ debug "Nets for VMs: %s" (String.concat "," (List.map (fun net -> Client.Network.get_name_label poolrpc poolses net) nets_for_vms));
+
+ let networks = Array.of_list nets_for_vms in
+
+ Printf.printf "Creating VMs (%s)\n%!" (if pool.use_shared_storage then "on shared storage" else "on local storage");
+ let storages = if pool.use_shared_storage then lun_srs else local_srs in
+ List.iter (fun vm -> CreateVM.make ~rpc:poolrpc ~session_id:poolses ~networks ~storages ~pool ~vm) pool.vms
let create_pool session_id sdkname pool_name key ipbase =
iscsi_vm_iso_must_exist session_id;
else Printf.sprintf "%s (%s)" key tag
let startall rpc session_id test =
- let vms = Client.VM.get_all_records rpc session_id in
- let tags = List.map (fun (vm,vmr) -> vmr.API.vM_tags) vms in
- let tags = List.setify (List.flatten tags) in
- List.map (fun tag ->
- debug "Starting VMs with tag: %s" tag;
- let vms = List.filter (fun (vm,vmr) -> List.mem tag vmr.API.vM_tags) vms in
- let vms = List.sort (fun (vm1,vmr1) (vm2,vmr2) -> compare vmr1.API.vM_affinity vmr2.API.vM_affinity) vms in
- let vms_names_uuids = List.map (fun (vm,vmr) -> (vm,vmr.API.vM_name_label, vmr.API.vM_uuid)) vms in
- let times = List.map
- (fun (vm,name_label,uuid) ->
- debug "Starting VM uuid '%s' (%s)" uuid name_label;
- let result = time (fun () -> Client.VM.start rpc session_id vm false false) in
- debug "Elapsed time: %f" result;
- result) vms_names_uuids in
- {resultname=test.testname; subtest=subtest_string test.key tag; xenrtresult=(List.fold_left (+.) 0.0 times); rawresult=StartTest times}
- ) tags
+ let vms = Client.VM.get_all_records rpc session_id in
+ let tags = List.map (fun (vm,vmr) -> vmr.API.vM_tags) vms in
+ let tags = List.setify (List.flatten tags) in
+ List.map
+ (fun tag ->
+ debug "Starting VMs with tag: %s" tag;
+ let vms = List.filter (fun (vm,vmr) -> List.mem tag vmr.API.vM_tags) vms in
+ let vms = List.sort (fun (vm1,vmr1) (vm2,vmr2) -> compare vmr1.API.vM_affinity vmr2.API.vM_affinity) vms in
+ let vms_names_uuids = List.map (fun (vm,vmr) -> (vm,vmr.API.vM_name_label, vmr.API.vM_uuid)) vms in
+ let times = List.map
+ (fun (vm,name_label,uuid) ->
+ debug "Starting VM uuid '%s' (%s)" uuid name_label;
+ let result = time (fun () -> Client.VM.start rpc session_id vm false false) in
+ debug "Elapsed time: %f" result;
+ result)
+ vms_names_uuids in
+ {
+ resultname=test.testname;
+ subtest=subtest_string test.key tag;
+ xenrtresult=(List.fold_left (+.) 0.0 times);
+ rawresult=StartTest times
+ })
+ tags
let parallel_with_vms async_op opname n vms rpc session_id test subtest_name =
(* Not starting in affinity order *)
| Suspend -> "suspend"
let change_vm_state session_id vm force st =
- Printf.printf "Telling vm to %s\n" (vmop_to_string st);
- (match st with
- Start -> Remote.VM.start session_id vm false
- | Shutdown ->
- if force
- then Remote.VM.hard_shutdown session_id vm
- else Remote.VM.clean_shutdown session_id vm
- | Suspend -> Remote.VM.pause session_id vm
- | Reboot ->
- if force
- then Remote.VM.hard_reboot session_id vm
- else Remote.VM.clean_shutdown session_id vm
- | Resume -> Remote.VM.unpause session_id vm);
- Remote.VM.get_power_state session_id vm
-
+ Printf.printf "Telling vm to %s\n" (vmop_to_string st);
+ (match st with
+ | Start -> Remote.VM.start session_id vm false
+ | Shutdown ->
+ if force
+ then Remote.VM.hard_shutdown session_id vm
+ else Remote.VM.clean_shutdown session_id vm
+ | Suspend -> Remote.VM.pause session_id vm
+ | Reboot ->
+ if force
+ then Remote.VM.hard_reboot session_id vm
+ else Remote.VM.clean_shutdown session_id vm
+ | Resume -> Remote.VM.unpause session_id vm);
+ Remote.VM.get_power_state session_id vm
+
let power_state_to_string state =
match state with
`Halted -> "Halted"
open Toplevelhelper
let _ =
- host := "mindanao";
- port := 8086;
- let s = init_session "root" "xenroot" in
- let vm = List.nth (Remote.VM.get_by_name_label s Sys.argv.(1)) 0 in
- Remote.VM.start s vm false
+ host := "mindanao";
+ port := 8086;
+ let s = init_session "root" "xenroot" in
+ let vm = List.nth (Remote.VM.get_by_name_label s Sys.argv.(1)) 0 in
+ Remote.VM.start s vm false
)
)
- let start ~__context ~vm ~start_paused ~force =
- info "VM.start: VM = '%s'" (vm_uuid ~__context vm);
- let local_fn = Local.VM.start ~vm ~start_paused ~force in
-
- let host =
- with_vm_operation ~__context ~self:vm ~doc:"VM.start" ~op:`start
- (fun () ->
- with_vbds_marked ~__context ~vm ~doc:"VM.start" ~op:`attach
- (fun vbds ->
- with_vifs_marked ~__context ~vm ~doc:"VM.start" ~op:`attach
- (fun vifs ->
- (* The start operation makes use of the cached memory overhead *)
- (* value when reserving memory. It's important to recalculate *)
- (* the cached value before performing the start since there's *)
- (* no guarantee that the cached value is valid. In particular, *)
- (* we must recalculate the value BEFORE creating the snapshot. *)
- Xapi_vm_helpers.update_memory_overhead ~__context ~vm;
- let snapshot = Db.VM.get_record ~__context ~self:vm in
- forward_to_suitable_host ~local_fn ~__context ~vm ~snapshot ~host_op:`vm_start
- (fun session_id rpc -> Client.VM.start rpc session_id vm start_paused force))))
- in
- update_vbd_operations ~__context ~vm;
- update_vif_operations ~__context ~vm;
- let uuid = Db.VM.get_uuid ~__context ~self:vm in
- let message_body =
- Printf.sprintf "VM '%s' started on host: %s (uuid: %s)"
- (Db.VM.get_name_label ~__context ~self:vm)
- (Db.Host.get_name_label ~__context ~self:host)
- (Db.Host.get_uuid ~__context ~self:host)
- in
- (try ignore(Xapi_message.create ~__context ~name:Api_messages.vm_started
- ~priority:1L ~cls:`VM ~obj_uuid:uuid ~body:message_body) with _ -> ());
- Monitor_rrds.push_rrd __context uuid
-
- let start_on ~__context ~vm ~host ~start_paused ~force =
- info "VM.start_on: VM = '%s'; host '%s'" (vm_uuid ~__context vm) (host_uuid ~__context host);
- let local_fn = Local.VM.start_on ~vm ~host ~start_paused ~force in
-
- with_vm_operation ~__context ~self:vm ~doc:"VM.start_on" ~op:`start_on
- (fun () ->
- with_vbds_marked ~__context ~vm ~doc:"VM.start_on" ~op:`attach
- (fun vbds ->
- with_vifs_marked ~__context ~vm ~doc:"VM.start_on" ~op:`attach
- (fun vifs ->
- (* The start operation makes use of the cached memory overhead *)
- (* value when reserving memory. It's important to recalculate *)
- (* the cached value before performing the start since there's *)
- (* no guarantee that the cached value is valid. In particular, *)
- (* we must recalculate the value BEFORE creating the snapshot. *)
- Xapi_vm_helpers.update_memory_overhead ~__context ~vm;
-
- let snapshot = Db.VM.get_record ~__context ~self:vm in
- reserve_memory_for_vm ~__context ~vm ~host ~snapshot ~host_op:`vm_start
- (fun () ->
- do_op_on ~local_fn ~__context ~host
- (fun session_id rpc -> Client.VM.start rpc session_id vm start_paused force)))));
- update_vbd_operations ~__context ~vm;
- update_vif_operations ~__context ~vm;
- let _ (* uuid *) = Db.VM.get_uuid ~__context ~self:vm in
- let message_body =
- Printf.sprintf "VM '%s' started on host: %s (uuid: %s)"
- (Db.VM.get_name_label ~__context ~self:vm)
- (Db.Host.get_name_label ~__context ~self:host)
- (Db.Host.get_uuid ~__context ~self:host)
- in
- (try ignore(Xapi_message.create ~__context ~name:Api_messages.vm_started
- ~priority:1L ~cls:`VM ~obj_uuid:(Db.VM.get_uuid ~__context ~self:vm) ~body:message_body) with _ -> ());
- Monitor_rrds.push_rrd __context (Db.VM.get_uuid ~__context ~self:vm)
+ let start ~__context ~vm ~start_paused ~force =
+ info "VM.start: VM = '%s'" (vm_uuid ~__context vm);
+ let local_fn = Local.VM.start ~vm ~start_paused ~force in
+ let host =
+ with_vm_operation ~__context ~self:vm ~doc:"VM.start" ~op:`start
+ (fun () ->
+ with_vbds_marked ~__context ~vm ~doc:"VM.start" ~op:`attach
+ (fun vbds ->
+ with_vifs_marked ~__context ~vm ~doc:"VM.start" ~op:`attach
+ (fun vifs ->
+ (* The start operation makes use of the cached memory overhead *)
+ (* value when reserving memory. It's important to recalculate *)
+ (* the cached value before performing the start since there's *)
+ (* no guarantee that the cached value is valid. In particular, *)
+ (* we must recalculate the value BEFORE creating the snapshot. *)
+ Xapi_vm_helpers.update_memory_overhead ~__context ~vm;
+ let snapshot = Db.VM.get_record ~__context ~self:vm in
+ forward_to_suitable_host ~local_fn ~__context ~vm ~snapshot ~host_op:`vm_start
+ (fun session_id rpc ->
+ Client.VM.start
+ rpc
+ session_id
+ vm
+ start_paused
+ force)))) in
+ update_vbd_operations ~__context ~vm;
+ update_vif_operations ~__context ~vm;
+ let uuid = Db.VM.get_uuid ~__context ~self:vm in
+ let message_body =
+ Printf.sprintf "VM '%s' started on host: %s (uuid: %s)"
+ (Db.VM.get_name_label ~__context ~self:vm)
+ (Db.Host.get_name_label ~__context ~self:host)
+ (Db.Host.get_uuid ~__context ~self:host)
+ in
+ (try ignore
+ (Xapi_message.create
+ ~__context
+ ~name:Api_messages.vm_started
+ ~priority:1L
+ ~cls:`VM
+ ~obj_uuid:uuid
+ ~body:message_body)
+ with _ -> ());
+ Monitor_rrds.push_rrd __context uuid
+
+ let start_on ~__context ~vm ~host ~start_paused ~force =
+ info "VM.start_on: VM = '%s'; host '%s'"
+ (vm_uuid ~__context vm) (host_uuid ~__context host);
+ let local_fn = Local.VM.start_on ~vm ~host ~start_paused ~force in
+ with_vm_operation ~__context ~self:vm ~doc:"VM.start_on" ~op:`start_on
+ (fun () ->
+ with_vbds_marked ~__context ~vm ~doc:"VM.start_on" ~op:`attach
+ (fun vbds ->
+ with_vifs_marked ~__context ~vm ~doc:"VM.start_on" ~op:`attach
+ (fun vifs ->
+ (* The start operation makes use of the cached memory overhead *)
+ (* value when reserving memory. It's important to recalculate *)
+ (* the cached value before performing the start since there's *)
+ (* no guarantee that the cached value is valid. In particular, *)
+ (* we must recalculate the value BEFORE creating the snapshot. *)
+ Xapi_vm_helpers.update_memory_overhead ~__context ~vm;
+ let snapshot = Db.VM.get_record ~__context ~self:vm in
+ reserve_memory_for_vm ~__context ~vm ~host ~snapshot ~host_op:`vm_start
+ (fun () ->
+ do_op_on ~local_fn ~__context ~host
+ (fun session_id rpc ->
+ Client.VM.start
+ rpc
+ session_id
+ vm
+ start_paused
+ force)))));
+ update_vbd_operations ~__context ~vm;
+ update_vif_operations ~__context ~vm;
+ let _ (* uuid *) = Db.VM.get_uuid ~__context ~self:vm in
+ let message_body =
+ Printf.sprintf "VM '%s' started on host: %s (uuid: %s)"
+ (Db.VM.get_name_label ~__context ~self:vm)
+ (Db.Host.get_name_label ~__context ~self:host)
+ (Db.Host.get_uuid ~__context ~self:host) in
+ (try ignore
+ (Xapi_message.create
+ ~__context
+ ~name:Api_messages.vm_started
+ ~priority:1L
+ ~cls:`VM
+ ~obj_uuid:(Db.VM.get_uuid ~__context ~self:vm)
+ ~body:message_body)
+ with _ -> ());
+ Monitor_rrds.push_rrd __context (Db.VM.get_uuid ~__context ~self:vm)
let pause ~__context ~vm =
info "VM.pause: VM = '%s'" (vm_uuid ~__context vm);
(* CA-24232 serialising VBD.pause VBD.unpause *)
let vbd_pause_unpause_test session_id vm =
- let vm = Client.VM.clone !rpc session_id vm "vbd-pause-unpause-test" in
- let test = make_test "VBD.pause and VBD.unpause" 1 in
- start test;
- finally
- (fun () ->
- let vbds = Client.VM.get_VBDs !rpc session_id vm in
- (* CA-24275 *)
- debug test "VBD.pause should fail for offline VMs";
- let vbd = List.hd vbds in
- begin
- try
- ignore(Client.VBD.pause !rpc session_id vbd);
- failed test "VBD.pause should not have succeeded";
- with
- | (Api_errors.Server_error(code, params)) when code = Api_errors.vm_bad_power_state -> ()
- | e ->
- failed test (Printf.sprintf "Unexpected exception from VBD.pause: %s" (Printexc.to_string e))
- end;
- debug test "VBD.unpause should fail for offline VMs";
- begin
- try
- ignore(Client.VBD.unpause !rpc session_id vbd "");
- failed test "VBD.unpause should not have succeeded";
- with
- | (Api_errors.Server_error(code, params)) when code = Api_errors.vm_bad_power_state -> ()
- | e ->
- failed test (Printf.sprintf "Unexpected exception from VBD.pause: %s" (Printexc.to_string e))
- end;
- debug test "Starting VM";
- Client.VM.start !rpc session_id vm false false;
- debug test "A solitary unpause should succeed";
- Client.VBD.unpause !rpc session_id vbd "";
- debug test "100 pause/unpause cycles should succeed";
- for i = 0 to 100 do
- let token = Client.VBD.pause !rpc session_id vbd in
- Client.VBD.unpause !rpc session_id vbd token
- done;
- debug test "force-shutdown should still work even if a device is paused";
- debug test "pausing device";
- let token = Client.VBD.pause !rpc session_id vbd in
- debug test "performing hard shutdown";
- let (_: unit) = Client.VM.hard_shutdown !rpc session_id vm in
- begin
- try
- ignore(Client.VBD.unpause !rpc session_id vbd "");
- failed test "VBD.unpause should not have succeeded";
- with
- | (Api_errors.Server_error(code, params)) when code = Api_errors.vm_bad_power_state -> ()
- | e ->
- failed test (Printf.sprintf "Unexpected exception from VBD.pause: %s" (Printexc.to_string e))
- end;
- debug test "starting VM again";
- try
- Client.VM.start !rpc session_id vm false false;
- Client.VBD.unpause !rpc session_id vbd token;
- with
- | Api_errors.Server_error(code, params) as e ->
- debug test (Printf.sprintf "Api_error %s [ %s ]" code (String.concat "; " params));
- raise e
- | e ->
- debug test (Printf.sprintf "Exception: %s" (Printexc.to_string e));
- raise e
- ) (fun () ->
- Client.VM.hard_shutdown !rpc session_id vm;
- vm_uninstall test session_id vm);
- success test
+ let vm = Client.VM.clone !rpc session_id vm "vbd-pause-unpause-test" in
+ let test = make_test "VBD.pause and VBD.unpause" 1 in
+ start test;
+ finally
+ (fun () ->
+ let vbds = Client.VM.get_VBDs !rpc session_id vm in
+ (* CA-24275 *)
+ debug test "VBD.pause should fail for offline VMs";
+ let vbd = List.hd vbds in
+ begin
+ try
+ ignore(Client.VBD.pause !rpc session_id vbd);
+ failed test "VBD.pause should not have succeeded";
+ with
+ | (Api_errors.Server_error(code, params)) when code = Api_errors.vm_bad_power_state -> ()
+ | e ->
+ failed test (Printf.sprintf "Unexpected exception from VBD.pause: %s" (Printexc.to_string e))
+ end;
+ debug test "VBD.unpause should fail for offline VMs";
+ begin
+ try
+ ignore(Client.VBD.unpause !rpc session_id vbd "");
+ failed test "VBD.unpause should not have succeeded";
+ with
+ | (Api_errors.Server_error(code, params)) when code = Api_errors.vm_bad_power_state -> ()
+ | e ->
+ failed test (Printf.sprintf "Unexpected exception from VBD.pause: %s" (Printexc.to_string e))
+ end;
+ debug test "Starting VM";
+ Client.VM.start !rpc session_id vm false false;
+ debug test "A solitary unpause should succeed";
+ Client.VBD.unpause !rpc session_id vbd "";
+ debug test "100 pause/unpause cycles should succeed";
+ for i = 0 to 100 do
+ let token = Client.VBD.pause !rpc session_id vbd in
+ Client.VBD.unpause !rpc session_id vbd token
+ done;
+ debug test "force-shutdown should still work even if a device is paused";
+ debug test "pausing device";
+ let token = Client.VBD.pause !rpc session_id vbd in
+ debug test "performing hard shutdown";
+ let (_: unit) = Client.VM.hard_shutdown !rpc session_id vm in
+ begin
+ try
+ ignore(Client.VBD.unpause !rpc session_id vbd "");
+ failed test "VBD.unpause should not have succeeded";
+ with
+ | (Api_errors.Server_error(code, params)) when code = Api_errors.vm_bad_power_state -> ()
+ | e ->
+ failed test (Printf.sprintf "Unexpected exception from VBD.pause: %s" (Printexc.to_string e))
+ end;
+ debug test "starting VM again";
+ try
+ Client.VM.start !rpc session_id vm false false;
+ Client.VBD.unpause !rpc session_id vbd token;
+ with
+ | Api_errors.Server_error(code, params) as e ->
+ debug test (Printf.sprintf "Api_error %s [ %s ]" code (String.concat "; " params));
+ raise e
+ | e ->
+ debug test (Printf.sprintf "Exception: %s" (Printexc.to_string e));
+ raise e
+ ) (fun () ->
+ Client.VM.hard_shutdown !rpc session_id vm;
+ vm_uninstall test session_id vm);
+ success test
let read_sys path = Stringext.String.strip Stringext.String.isspace (Unixext.string_of_file path)
(* CP-831 *)
let test_vhd_locking_hook session_id vm =
- let test = make_test "test vhd locking hook" 2 in
- start test;
- Client.VM.start !rpc session_id vm false false;
- (* Add a new VDI whose VBD is unplugged (so 2 plugged, 1 unplugged *)
- let vbds = Client.VM.get_VBDs !rpc session_id vm in
- let vdis = List.map (fun vbd -> Client.VBD.get_VDI !rpc session_id vbd) vbds in
-
- let pool = get_pool session_id in
- let default_SR = Client.Pool.get_default_SR !rpc session_id pool in
- let new_vdi = Client.VDI.create !rpc session_id "lvhd_testvdi"
- "description" default_SR 4194304L `user false false [] [] [] [] in
- let new_vbd = Client.VBD.create ~rpc:!rpc ~session_id ~vM:vm ~vDI:new_vdi ~userdevice:"9" ~bootable:false
- ~mode:`RW ~_type:`Disk ~unpluggable:true ~empty:false ~other_config:[Xapi_globs.owner_key,""]
- ~qos_algorithm_type:"" ~qos_algorithm_params:[] in
-
- (* In a background thread plug/unplug the new VBD to cause some transient locking failures *)
- let start = Unix.gettimeofday () in
- debug test "Starting up conflicting thread in the background";
- let total_bg_ops = ref 0 in
- let t = Thread.create
- (fun () ->
- while Unix.gettimeofday () -. start < 30. do
- (* We throw away exceptions because unplugs can fail (if the guest isn't ready) and this causes the
- next plug to fail. We use asynchronous operations because we are sharing a single HTTP connection to the
- master and we genuinely want the operations to (attempt to) execute in parallel *)
- let task = Client.Async.VBD.plug !rpc session_id new_vbd in
- incr total_bg_ops;
- wait_for_task_complete session_id task;
- let task = Client.Async.VBD.unplug !rpc session_id new_vbd in
- incr total_bg_ops;
- wait_for_task_complete session_id task
- done) () in
- (* Give the background thread a chance to start *)
- Thread.delay 1.5;
- (* Verify that the function 'test' can be called in the script *)
-
- while Unix.gettimeofday () -. start < 30. do
- let start' = Unix.gettimeofday () in
- let result = Client.SR.lvhd_stop_using_these_vdis_and_call_script !rpc session_id vdis "echo" "main" [ ] in
- debug test (Printf.sprintf "lvhd-script-hook tool %.2f seconds; output was: %s" (Unix.gettimeofday () -. start') result);
- done;
- Thread.join t;
- debug test (Printf.sprintf "Meanwhile background thread executed %d conflicting operations" !total_bg_ops);
- success test
+ let test = make_test "test vhd locking hook" 2 in
+ start test;
+ Client.VM.start !rpc session_id vm false false;
+ (* Add a new VDI whose VBD is unplugged (so 2 plugged, 1 unplugged *)
+ let vbds = Client.VM.get_VBDs !rpc session_id vm in
+ let vdis = List.map (fun vbd -> Client.VBD.get_VDI !rpc session_id vbd) vbds in
+
+ let pool = get_pool session_id in
+ let default_SR = Client.Pool.get_default_SR !rpc session_id pool in
+ let new_vdi = Client.VDI.create !rpc session_id "lvhd_testvdi"
+ "description" default_SR 4194304L `user false false [] [] [] [] in
+ let new_vbd = Client.VBD.create ~rpc:!rpc ~session_id ~vM:vm ~vDI:new_vdi ~userdevice:"9" ~bootable:false
+ ~mode:`RW ~_type:`Disk ~unpluggable:true ~empty:false ~other_config:[Xapi_globs.owner_key,""]
+ ~qos_algorithm_type:"" ~qos_algorithm_params:[] in
+
+ (* In a background thread plug/unplug the new VBD to cause some transient locking failures *)
+ let start = Unix.gettimeofday () in
+ debug test "Starting up conflicting thread in the background";
+ let total_bg_ops = ref 0 in
+ let t = Thread.create
+ (fun () ->
+ while Unix.gettimeofday () -. start < 30. do
+ (* We throw away exceptions because unplugs can fail (if the guest isn't ready) and this causes the
+ next plug to fail. We use asynchronous operations because we are sharing a single HTTP connection to the
+ master and we genuinely want the operations to (attempt to) execute in parallel *)
+ let task = Client.Async.VBD.plug !rpc session_id new_vbd in
+ incr total_bg_ops;
+ wait_for_task_complete session_id task;
+ let task = Client.Async.VBD.unplug !rpc session_id new_vbd in
+ incr total_bg_ops;
+ wait_for_task_complete session_id task
+ done) () in
+ (* Give the background thread a chance to start *)
+ Thread.delay 1.5;
+ (* Verify that the function 'test' can be called in the script *)
+
+ while Unix.gettimeofday () -. start < 30. do
+ let start' = Unix.gettimeofday () in
+ let result = Client.SR.lvhd_stop_using_these_vdis_and_call_script !rpc session_id vdis "echo" "main" [ ] in
+ debug test (Printf.sprintf "lvhd-script-hook tool %.2f seconds; output was: %s" (Unix.gettimeofday () -. start') result);
+ done;
+ Thread.join t;
+ debug test (Printf.sprintf "Meanwhile background thread executed %d conflicting operations" !total_bg_ops);
+ success test
let powercycle_test session_id vm =
- let test = make_test "Powercycling VM" 1 in
- start test;
- (* avoid the race whereby reboot requests are ignored if too early *)
- let delay () =
- debug test "Pausing for 10s";
- Thread.delay 10. in
- debug test (Printf.sprintf "Trying to enable VM.clone for suspended VMs pool-wide");
- let pool = get_pool session_id in
- let enabled_csvm =
- try Client.Pool.add_to_other_config !rpc session_id pool "allow_clone_suspended_vm" "true"; true
- with _ -> false in
- finally
- (fun () ->
- (* We play with three VMs:
- 1. a clean install of a VM (vm)
- 2. a suspended clone of (1) (vm')
- 3. a metadata import of the metadata export of (2) (vm'')
- *)
- debug test "Starting VM";
- Client.VM.start !rpc session_id vm false false;
- delay ();
- debug test "Rebooting VM";
- Client.VM.clean_reboot !rpc session_id vm;
- delay ();
- debug test "Shutting down VM";
- Client.VM.clean_shutdown !rpc session_id vm;
- debug test "Starting VM again";
- Client.VM.start !rpc session_id vm false false;
- verify_network_connectivity session_id test vm;
- delay ();
- debug test "Setting shadow-multiplier live to 10.";
- Client.VM.set_shadow_multiplier_live !rpc session_id vm 10.;
- delay ();
- debug test "Suspending VM";
- Client.VM.suspend !rpc session_id vm;
- debug test "Cloning suspended VM";
- let vm' = Client.VM.clone !rpc session_id vm "clone-suspended-test" in
- debug test "Snapshoting the VM twice";
- let snap1 = Client.VM.snapshot !rpc session_id vm' "snap1" in
- let snap2 = Client.VM.snapshot !rpc session_id vm' "snap2" in
-
- debug test "Comparing original, clone VIF configuration";
- compare_vifs session_id test vm vm';
- debug test "Comparing original, clone VM configuration";
- compare_vms session_id test vm vm';
-
- debug test "Importing metadata export of cloned suspended VM";
- Unixext.unlink_safe export_filename;
- vm_export ~metadata_only:true test session_id vm' export_filename;
- let vms = vm_import ~metadata_only:true test session_id export_filename in
- let vm'' = List.find (fun vm -> Client.VM.get_name_label !rpc session_id vm = "clone-suspended-test") vms in
- debug test "Comparing clone, import VIF configuration";
- compare_vifs session_id test vm' vm'';
- debug test "Comparing clone, import VBD configuration";
- compare_vbds session_id test vm' vm'';
- debug test "Comparing clone, import VM configuration";
- compare_vms session_id test vm' vm'';
- debug test "Comparing clone, import snapshot configuration";
- compare_snapshots session_id test vm' vm'';
- debug test "Comparing original, import VIF configuration";
- compare_vifs session_id test vm vm'';
- debug test "Comparing original, import VM configuration";
- compare_vms session_id test vm vm'';
-
- debug test "Resuming original VM";
- Client.VM.resume !rpc session_id vm false false;
- verify_network_connectivity session_id test vm;
- let host = Client.VM.get_resident_on !rpc session_id vm in
- debug test "Performing localhost migrate of original VM";
- Client.VM.pool_migrate !rpc session_id vm host [];
- verify_network_connectivity session_id test vm;
- debug test "Shutting down original VM";
- Client.VM.clean_shutdown !rpc session_id vm;
- debug test "Resuming imported VM";
- Client.VM.resume !rpc session_id vm'' false false;
- verify_network_connectivity session_id test vm'';
- debug test "Shutting down imported VMs";
- List.iter (fun vm -> if Client.VM.get_power_state !rpc session_id vm <> `Halted then Client.VM.hard_shutdown !rpc session_id vm) vms;
-
- (* Keep the imported VM and chuck away the clone *)
- (* NB cannot do this earlier because the suspend VDI would be destroyed
- and prevent the other VM being resumed *)
- Client.VM.hard_shutdown !rpc session_id vm';
- vm_uninstall test session_id vm';
-
- debug test "Uninstalling imported VMs";
- List.iter (vm_uninstall test session_id) vms;
- success test;
- ) (fun () ->
- if enabled_csvm then begin
- debug test (Printf.sprintf "Disabling VM.clone for suspended VMs pool-wide");
- Client.Pool.remove_from_other_config !rpc session_id pool "allow_clone_suspended_vm"
- end)
+ let test = make_test "Powercycling VM" 1 in
+ start test;
+ (* avoid the race whereby reboot requests are ignored if too early *)
+ let delay () =
+ debug test "Pausing for 10s";
+ Thread.delay 10. in
+ debug test (Printf.sprintf "Trying to enable VM.clone for suspended VMs pool-wide");
+ let pool = get_pool session_id in
+ let enabled_csvm =
+ try Client.Pool.add_to_other_config !rpc session_id pool "allow_clone_suspended_vm" "true"; true
+ with _ -> false in
+ finally
+ (fun () ->
+ (* We play with three VMs:
+ 1. a clean install of a VM (vm)
+ 2. a suspended clone of (1) (vm')
+ 3. a metadata import of the metadata export of (2) (vm'')
+ *)
+ debug test "Starting VM";
+ Client.VM.start !rpc session_id vm false false;
+ delay ();
+ debug test "Rebooting VM";
+ Client.VM.clean_reboot !rpc session_id vm;
+ delay ();
+ debug test "Shutting down VM";
+ Client.VM.clean_shutdown !rpc session_id vm;
+ debug test "Starting VM again";
+ Client.VM.start !rpc session_id vm false false;
+ verify_network_connectivity session_id test vm;
+ delay ();
+ debug test "Setting shadow-multiplier live to 10.";
+ Client.VM.set_shadow_multiplier_live !rpc session_id vm 10.;
+ delay ();
+ debug test "Suspending VM";
+ Client.VM.suspend !rpc session_id vm;
+ debug test "Cloning suspended VM";
+ let vm' = Client.VM.clone !rpc session_id vm "clone-suspended-test" in
+ debug test "Snapshoting the VM twice";
+ let snap1 = Client.VM.snapshot !rpc session_id vm' "snap1" in
+ let snap2 = Client.VM.snapshot !rpc session_id vm' "snap2" in
+
+ debug test "Comparing original, clone VIF configuration";
+ compare_vifs session_id test vm vm';
+ debug test "Comparing original, clone VM configuration";
+ compare_vms session_id test vm vm';
+
+ debug test "Importing metadata export of cloned suspended VM";
+ Unixext.unlink_safe export_filename;
+ vm_export ~metadata_only:true test session_id vm' export_filename;
+ let vms = vm_import ~metadata_only:true test session_id export_filename in
+ let vm'' = List.find (fun vm -> Client.VM.get_name_label !rpc session_id vm = "clone-suspended-test") vms in
+ debug test "Comparing clone, import VIF configuration";
+ compare_vifs session_id test vm' vm'';
+ debug test "Comparing clone, import VBD configuration";
+ compare_vbds session_id test vm' vm'';
+ debug test "Comparing clone, import VM configuration";
+ compare_vms session_id test vm' vm'';
+ debug test "Comparing clone, import snapshot configuration";
+ compare_snapshots session_id test vm' vm'';
+ debug test "Comparing original, import VIF configuration";
+ compare_vifs session_id test vm vm'';
+ debug test "Comparing original, import VM configuration";
+ compare_vms session_id test vm vm'';
+
+ debug test "Resuming original VM";
+ Client.VM.resume !rpc session_id vm false false;
+ verify_network_connectivity session_id test vm;
+ let host = Client.VM.get_resident_on !rpc session_id vm in
+ debug test "Performing localhost migrate of original VM";
+ Client.VM.pool_migrate !rpc session_id vm host [];
+ verify_network_connectivity session_id test vm;
+ debug test "Shutting down original VM";
+ Client.VM.clean_shutdown !rpc session_id vm;
+ debug test "Resuming imported VM";
+ Client.VM.resume !rpc session_id vm'' false false;
+ verify_network_connectivity session_id test vm'';
+ debug test "Shutting down imported VMs";
+ List.iter (fun vm -> if Client.VM.get_power_state !rpc session_id vm <> `Halted then Client.VM.hard_shutdown !rpc session_id vm) vms;
+
+ (* Keep the imported VM and chuck away the clone *)
+ (* NB cannot do this earlier because the suspend VDI would be destroyed
+ and prevent the other VM being resumed *)
+ Client.VM.hard_shutdown !rpc session_id vm';
+ vm_uninstall test session_id vm';
+
+ debug test "Uninstalling imported VMs";
+ List.iter (vm_uninstall test session_id) vms;
+ success test;
+ ) (fun () ->
+ if enabled_csvm then begin
+ debug test (Printf.sprintf "Disabling VM.clone for suspended VMs pool-wide");
+ Client.Pool.remove_from_other_config !rpc session_id pool "allow_clone_suspended_vm"
+ end)
(* Make a VDI, find a host to put it on, create a VBD to dom0 on that host,
* Attach, Unattach, destroy VBD, destroy VDI *)
open Pervasiveext
let one s vm test =
- let t = make_test (string_of_test test) 1 in
- start t;
- let event = "/tmp/fist_disable_event_lifecycle_path" in
- let sync = "/tmp/fist_disable_sync_lifecycle_path" in
- let simulate = "/tmp/fist_simulate_internal_shutdown" in
- let delay = "/tmp/fist_disable_reboot_delay" in
-
- finally
- (fun () ->
- try
- begin
- Unixext.unlink_safe simulate;
- Unixext.touch_file delay;
- match test.code_path with
- | Sync ->
- Unixext.unlink_safe sync;
- Unixext.touch_file event
- | Event ->
- Unixext.unlink_safe event;
- Unixext.touch_file sync
- | Both ->
- Unixext.unlink_safe sync;
- Unixext.unlink_safe event
- end;
- if Client.VM.get_power_state !rpc s vm = `Halted
- then Client.VM.start !rpc s vm false false;
-
- let call_api = function
- | Shutdown Clean -> Client.VM.clean_shutdown !rpc s vm
- | Shutdown Hard -> Client.VM.hard_shutdown !rpc s vm
- | Reboot Clean -> Client.VM.clean_reboot !rpc s vm
- | Reboot Hard -> Client.VM.hard_reboot !rpc s vm in
-
- let domid = Client.VM.get_domid !rpc s vm in
- begin match test with
- | { api = None; parallel_op = Some x } ->
- let reason = match x with
- | Internal_reboot -> Xc.Reboot
- | Internal_halt -> Xc.Halt
- | Internal_crash -> Xc.Crash
- | Internal_suspend -> Xc.Suspend in
- begin
- try
- Xc.with_intf (fun xc -> Xc.domain_shutdown xc (Int64.to_int domid) reason)
- with e ->
- debug t (Printf.sprintf "Ignoring exception: %s" (Printexc.to_string e))
- end
- | { api = Some x; parallel_op = Some y } ->
- let reason = match y with
- | Internal_reboot -> "reboot"
- | Internal_halt -> "halt"
- | Internal_crash -> "crash"
- | Internal_suspend -> "suspend" in
- Unixext.write_string_to_file simulate reason;
- call_api x
- | { api = Some x; parallel_op = None } ->
- call_api x
- | t -> failwith (Printf.sprintf "Invalid test: %s" (string_of_test t))
- end;
-
- let wait_for_domid p =
- let start = Unix.gettimeofday () in
- let finished = ref false in
- while Unix.gettimeofday () -. start < 300. && (not !finished) do
- finished := p (Client.VM.get_domid !rpc s vm);
- if not !finished then Thread.delay 1.
- done;
- if not !finished then failwith "timeout"
- in
-
- begin match expected_result test with
- | None -> failwith (Printf.sprintf "Invalid test: %s" (string_of_test test))
- | Some Rebooted ->
- wait_for_domid (fun domid' -> domid <> domid')
- | Some Halted ->
- wait_for_domid (fun domid' -> domid' = -1L)
- end
- with e -> failed t (Printexc.to_string e)
- )
- (fun () ->
- Unixext.unlink_safe sync;
- Unixext.unlink_safe event;
- Unixext.unlink_safe delay
- );
- success t
+ let t = make_test (string_of_test test) 1 in
+ start t;
+ let event = "/tmp/fist_disable_event_lifecycle_path" in
+ let sync = "/tmp/fist_disable_sync_lifecycle_path" in
+ let simulate = "/tmp/fist_simulate_internal_shutdown" in
+ let delay = "/tmp/fist_disable_reboot_delay" in
+
+ finally
+ (fun () ->
+ try
+ begin
+ Unixext.unlink_safe simulate;
+ Unixext.touch_file delay;
+ match test.code_path with
+ | Sync ->
+ Unixext.unlink_safe sync;
+ Unixext.touch_file event
+ | Event ->
+ Unixext.unlink_safe event;
+ Unixext.touch_file sync
+ | Both ->
+ Unixext.unlink_safe sync;
+ Unixext.unlink_safe event
+ end;
+ if Client.VM.get_power_state !rpc s vm = `Halted
+ then Client.VM.start !rpc s vm false false;
+
+ let call_api = function
+ | Shutdown Clean -> Client.VM.clean_shutdown !rpc s vm
+ | Shutdown Hard -> Client.VM.hard_shutdown !rpc s vm
+ | Reboot Clean -> Client.VM.clean_reboot !rpc s vm
+ | Reboot Hard -> Client.VM.hard_reboot !rpc s vm in
+
+ let domid = Client.VM.get_domid !rpc s vm in
+ begin match test with
+ | { api = None; parallel_op = Some x } ->
+ let reason = match x with
+ | Internal_reboot -> Xc.Reboot
+ | Internal_halt -> Xc.Halt
+ | Internal_crash -> Xc.Crash
+ | Internal_suspend -> Xc.Suspend in
+ begin
+ try
+ Xc.with_intf (fun xc -> Xc.domain_shutdown xc (Int64.to_int domid) reason)
+ with e ->
+ debug t (Printf.sprintf "Ignoring exception: %s" (Printexc.to_string e))
+ end
+ | { api = Some x; parallel_op = Some y } ->
+ let reason = match y with
+ | Internal_reboot -> "reboot"
+ | Internal_halt -> "halt"
+ | Internal_crash -> "crash"
+ | Internal_suspend -> "suspend" in
+ Unixext.write_string_to_file simulate reason;
+ call_api x
+ | { api = Some x; parallel_op = None } ->
+ call_api x
+ | t -> failwith (Printf.sprintf "Invalid test: %s" (string_of_test t))
+ end;
+
+ let wait_for_domid p =
+ let start = Unix.gettimeofday () in
+ let finished = ref false in
+ while Unix.gettimeofday () -. start < 300. && (not !finished) do
+ finished := p (Client.VM.get_domid !rpc s vm);
+ if not !finished then Thread.delay 1.
+ done;
+ if not !finished then failwith "timeout"
+ in
+
+ begin match expected_result test with
+ | None -> failwith (Printf.sprintf "Invalid test: %s" (string_of_test test))
+ | Some Rebooted ->
+ wait_for_domid (fun domid' -> domid <> domid')
+ | Some Halted ->
+ wait_for_domid (fun domid' -> domid' = -1L)
+ end
+ with e -> failed t (Printexc.to_string e)
+ )
+ (fun () ->
+ Unixext.unlink_safe sync;
+ Unixext.unlink_safe event;
+ Unixext.unlink_safe delay
+ );
+ success t
let test s vm =
List.iter (one s vm) all_valid_tests
(* Takes the current live_set and number of hosts we're planning to handle, updates the host records in the database
and restarts any offline protected VMs *)
let restart_auto_run_vms ~__context live_set n =
- (* ensure we have live=false on the host_metrics for those hosts not in the live_set; and force state to Halted for
- all VMs that are "running" or "paused" with resident_on set to one of the hosts that is now dead
- *)
- debug "restart_auto_run_vms called";
- let hosts = Db.Host.get_all ~__context in
- (* Keep a list of all the VMs whose power-states we force to Halted to use later in the
- 'best-effort' restart code. Note that due to the weakly consistent database this is not
- an accurate way to determine 'failed' VMs but it will suffice for our 'best-effort'
- category. *)
- let reset_vms = ref [] in
- List.iter
- (fun h ->
- if not (List.mem h live_set) then
- begin
- let hostname = Db.Host.get_hostname ~__context ~self:h in
- debug "Setting host %s to dead" hostname;
- (* Sample this before calling any hook scripts *)
- let resident_on_vms = Db.Host.get_resident_VMs ~__context ~self:h in
- (* Skip control domains *)
- let resident_on_vms = List.filter (fun vm -> not(Db.VM.get_is_control_domain ~__context ~self:vm)) resident_on_vms in
- reset_vms := resident_on_vms @ !reset_vms;
-
- (* ensure live=false *)
- begin
- try
- let h_metrics = Db.Host.get_metrics ~__context ~self:h in
- let current = Db.Host_metrics.get_live ~__context ~self:h_metrics in
- if current then begin
- (* Fire off a ha_host_failed message if the host hasn't just shut itself down *)
- let shutting_down = Threadext.Mutex.execute Xapi_globs.hosts_which_are_shutting_down_m (fun () -> !Xapi_globs.hosts_which_are_shutting_down) in
- if not (List.exists (fun x -> x=h) shutting_down) then begin
- let obj_uuid = Db.Host.get_uuid ~__context ~self:h in
- let host_name = Db.Host.get_name_label ~__context ~self:h in
- Xapi_alert.add ~name:Api_messages.ha_host_failed ~priority:Api_messages.ha_host_failed_priority ~cls:`Host ~obj_uuid
- ~body:(Printf.sprintf "Server '%s' has failed" host_name);
- end;
- (* Call external host failed hook (allows a third-party to use power-fencing if desired) *)
- Xapi_hooks.host_pre_declare_dead ~__context ~host:h ~reason:Xapi_hooks.reason__fenced;
- Db.Host_metrics.set_live ~__context ~self:h_metrics ~value:false; (* since slave is fenced, it will not set this to true again itself *)
- Xapi_host_helpers.update_allowed_operations ~__context ~self:h;
- Xapi_hooks.host_post_declare_dead ~__context ~host:h ~reason:Xapi_hooks.reason__fenced;
- end
- with _ ->
- (* if exn assume h_metrics doesn't exist, then "live" is defined to be false implicitly, so do nothing *)
- ()
- end;
- debug "Setting all VMs running or paused on %s to Halted" hostname;
- (* ensure all vms resident_on this host running or paused have their powerstates reset *)
-
- List.iter
- (fun vm ->
- let vm_powerstate = Db.VM.get_power_state ~__context ~self:vm in
- let control = Db.VM.get_is_control_domain ~__context ~self:vm in
- if not(control) && (vm_powerstate=`Running || vm_powerstate=`Paused) then
- Xapi_vm_lifecycle.force_state_reset ~__context ~self:vm ~value:`Halted
- )
- resident_on_vms
- end
- )
- hosts;
-
- (* If something has changed then we'd better refresh the pool status *)
- if !reset_vms <> [] then ignore(update_pool_status ~__context);
-
- (* At this point failed protected agile VMs are Halted, not resident_on anywhere *)
-
- let all_protected_vms = all_protected_vms ~__context in
-
- let plan, plan_is_complete =
- try
- if Xapi_fist.simulate_planner_failure () then failwith "fist_simulate_planner_failure";
- (* CA-23981: if the pool-pre-ha-vm-restart hook exists AND if we're about to auto-start some VMs then
- call the script hook first and then recompute the plan aftwards. Note that these VMs may either
- be protected or best-effort. For the protected ones we assume that these are included in the VM
- restart plan-- we ignore the possibility that the planner may fail here (even through there is some
- last-ditch code later to perform best-effort VM.starts). This is ok since it should never happen and
- this particular hook is really a 'best-effort' integration point since it conflicts with the overcommit
- protection.
- For the best-effort VMs we call the script
- when we have reset some VMs to halted (no guarantee there is enough resource but better safe than sorry) *)
- let plan, config, vms_not_restarted, non_agile_protected_vms_exist = compute_restart_plan ~__context ~all_protected_vms n in
- let plan, config, vms_not_restarted, non_agile_protected_vms_exist =
- if true
- && Xapi_hooks.pool_pre_ha_vm_restart_hook_exists ()
- && (plan <> [] || !reset_vms <> []) then begin
- (* We're about to soak up some resources for 'Level 1' VMs somewhere; before we do that give 'Level 2' VMs a shot *)
- (* Whatever this script does we don't let it break our restart thread *)
- begin
- try
- Xapi_hooks.pool_pre_ha_vm_restart_hook ~__context
- with e ->
- error "pool-pre-ha-vm-restart-hook failed: %s: continuing anyway" (ExnHelper.string_of_exn e)
- end;
- debug "Recomputing restart plan to take into account new state of the world after running the script";
- compute_restart_plan ~__context ~all_protected_vms n
- end else plan, config, vms_not_restarted, non_agile_protected_vms_exist (* nothing needs recomputing *)
- in
-
- (* If we are undercommitted then vms_not_restarted = [] and plan will include all offline protected_vms *)
- let plan_is_complete = vms_not_restarted = [] in
- plan, plan_is_complete
- with e ->
- error "Caught unexpected exception in HA planner: %s" (ExnHelper.string_of_exn e);
- [], false in
-
- (* Send at most one alert per protected VM failure *)
- let consider_sending_failed_alert_for vm =
- debug "We failed to restart protected VM %s: considering sending an alert" (Ref.string_of vm);
- if not(Hashtbl.mem restart_failed vm) then begin
- Hashtbl.replace restart_failed vm ();
- let obj_uuid = Db.VM.get_uuid ~__context ~self:vm in
- Xapi_alert.add ~name:Api_messages.ha_protected_vm_restart_failed ~priority:1L ~cls:`VM ~obj_uuid ~body:""
- end in
-
- (* execute the plan *)
- Helpers.call_api_functions ~__context
- (fun rpc session_id ->
-
- (* Helper function to start a VM somewhere. If the HA overcommit protection stops us then disable it and try once more.
- Returns true if the VM was restarted and false otherwise. *)
- let restart_vm vm ?host () =
- let go () =
-
- if Xapi_fist.simulate_restart_failure () then begin
- match Random.int 3 with
- | 0 -> raise (Api_errors.Server_error(Api_errors.ha_operation_would_break_failover_plan, []))
- | 1 -> raise (Api_errors.Server_error("FIST: unexpected exception", []))
- | 2 -> ()
- end;
-
- (* If we tried before and failed, don't retry again within 2 minutes *)
- let attempt_restart =
- if Hashtbl.mem last_start_attempt vm
- then Unix.gettimeofday () -. (Hashtbl.find last_start_attempt vm) > 120.
- else true in
-
- if attempt_restart then begin
- Hashtbl.replace last_start_attempt vm (Unix.gettimeofday ());
- match host with
- | None -> Client.Client.VM.start rpc session_id vm false true
- | Some h -> Client.Client.VM.start_on rpc session_id vm h false true
- end else failwith (Printf.sprintf "VM: %s restart attempt delayed for 120s" (Ref.string_of vm)) in
- try
- go ();
- true
- with
- | Api_errors.Server_error(code, params) when code = Api_errors.ha_operation_would_break_failover_plan ->
- (* This should never happen since the planning code would always allow the restart of a protected VM... *)
- error "Caught exception HA_OPERATION_WOULD_BREAK_FAILOVER_PLAN: setting pool as overcommitted and retrying";
- mark_pool_as_overcommitted ~__context;
- begin
- try
- go ();
- true
- with e ->
- error "Caught exception trying to restart VM %s: %s" (Ref.string_of vm) (ExnHelper.string_of_exn e);
- false
- end
- | e ->
- error "Caught exception trying to restart VM %s: %s" (Ref.string_of vm) (ExnHelper.string_of_exn e);
- false in
-
- (* Build a list of bools, one per Halted protected VM indicating whether we managed to start it or not *)
- let started =
- if not plan_is_complete then begin
- (* If the Pool is overcommitted the restart priority will make the difference between a VM restart or not,
- while if we're undercommitted the restart priority only affects the timing slightly. *)
- let all = List.filter (fun (_, r) -> r.API.vM_power_state = `Halted) all_protected_vms in
- let all = List.sort by_restart_priority all in
- warn "Failed to find plan to restart all protected VMs: falling back to simple VM.start in priority order";
- List.map (fun (vm, _) -> vm, restart_vm vm ()) all
- end else begin
- (* Walk over the VMs in priority order, starting each on the planned host *)
- let all = List.sort by_restart_priority (List.map (fun (vm, _) -> vm, Db.VM.get_record ~__context ~self:vm) plan) in
- List.map (fun (vm, _) ->
- vm, (if List.mem_assoc vm plan
- then restart_vm vm ~host:(List.assoc vm plan) ()
- else false)) all
- end in
- (* Perform one final restart attempt of any that weren't started. *)
- let started = List.map (fun (vm, started) -> match started with
- | true -> vm, true
- | false -> vm, restart_vm vm ()) started in
- (* Send an alert for any failed VMs *)
- List.iter (fun (vm, started) -> if not started then consider_sending_failed_alert_for vm) started;
-
- (* Forget about previously failed VMs which have gone *)
- let vms_we_know_about = List.map fst started in
- let gc_table tbl =
- let vms_in_table = Hashtbl.fold (fun vm _ acc -> vm :: acc) tbl [] in
- List.iter (fun vm -> if not(List.mem vm vms_we_know_about) then (debug "Forgetting VM: %s" (Ref.string_of vm); Hashtbl.remove tbl vm)) vms_in_table in
- gc_table last_start_attempt;
- gc_table restart_failed;
-
- (* Consider restarting the best-effort VMs we *think* have failed (but we might get this wrong --
- ok since this is 'best-effort'). NOTE we do not use the restart_vm function above as this will mark the
- pool as overcommitted if an HA_OPERATION_WOULD_BREAK_FAILOVER_PLAN is received (although this should never
- happen it's better safe than sorry) *)
- List.iter
- (fun vm ->
- try
- if Db.VM.get_power_state ~__context ~self:vm = `Halted
- && Db.VM.get_ha_always_run ~__context ~self:vm
- && Db.VM.get_ha_restart_priority ~__context ~self:vm = Constants.ha_restart_best_effort
- then Client.Client.VM.start rpc session_id vm false true
- with e ->
- error "Failed to restart best-effort VM %s (%s): %s"
- (Db.VM.get_uuid ~__context ~self:vm)
- (Db.VM.get_name_label ~__context ~self:vm)
- (ExnHelper.string_of_exn e)) !reset_vms
-
- )
+ (* ensure we have live=false on the host_metrics for those hosts not in the live_set; and force state to Halted for
+ all VMs that are "running" or "paused" with resident_on set to one of the hosts that is now dead
+ *)
+ debug "restart_auto_run_vms called";
+ let hosts = Db.Host.get_all ~__context in
+ (* Keep a list of all the VMs whose power-states we force to Halted to use later in the
+ 'best-effort' restart code. Note that due to the weakly consistent database this is not
+ an accurate way to determine 'failed' VMs but it will suffice for our 'best-effort'
+ category. *)
+ let reset_vms = ref [] in
+ List.iter
+ (fun h ->
+ if not (List.mem h live_set) then
+ begin
+ let hostname = Db.Host.get_hostname ~__context ~self:h in
+ debug "Setting host %s to dead" hostname;
+ (* Sample this before calling any hook scripts *)
+ let resident_on_vms = Db.Host.get_resident_VMs ~__context ~self:h in
+ (* Skip control domains *)
+ let resident_on_vms = List.filter (fun vm -> not(Db.VM.get_is_control_domain ~__context ~self:vm)) resident_on_vms in
+ reset_vms := resident_on_vms @ !reset_vms;
+
+ (* ensure live=false *)
+ begin
+ try
+ let h_metrics = Db.Host.get_metrics ~__context ~self:h in
+ let current = Db.Host_metrics.get_live ~__context ~self:h_metrics in
+ if current then begin
+ (* Fire off a ha_host_failed message if the host hasn't just shut itself down *)
+ let shutting_down = Threadext.Mutex.execute Xapi_globs.hosts_which_are_shutting_down_m (fun () -> !Xapi_globs.hosts_which_are_shutting_down) in
+ if not (List.exists (fun x -> x=h) shutting_down) then begin
+ let obj_uuid = Db.Host.get_uuid ~__context ~self:h in
+ let host_name = Db.Host.get_name_label ~__context ~self:h in
+ Xapi_alert.add ~name:Api_messages.ha_host_failed ~priority:Api_messages.ha_host_failed_priority ~cls:`Host ~obj_uuid
+ ~body:(Printf.sprintf "Server '%s' has failed" host_name);
+ end;
+ (* Call external host failed hook (allows a third-party to use power-fencing if desired) *)
+ Xapi_hooks.host_pre_declare_dead ~__context ~host:h ~reason:Xapi_hooks.reason__fenced;
+ Db.Host_metrics.set_live ~__context ~self:h_metrics ~value:false; (* since slave is fenced, it will not set this to true again itself *)
+ Xapi_host_helpers.update_allowed_operations ~__context ~self:h;
+ Xapi_hooks.host_post_declare_dead ~__context ~host:h ~reason:Xapi_hooks.reason__fenced;
+ end
+ with _ ->
+ (* if exn assume h_metrics doesn't exist, then "live" is defined to be false implicitly, so do nothing *)
+ ()
+ end;
+ debug "Setting all VMs running or paused on %s to Halted" hostname;
+ (* ensure all vms resident_on this host running or paused have their powerstates reset *)
+
+ List.iter
+ (fun vm ->
+ let vm_powerstate = Db.VM.get_power_state ~__context ~self:vm in
+ let control = Db.VM.get_is_control_domain ~__context ~self:vm in
+ if not(control) && (vm_powerstate=`Running || vm_powerstate=`Paused) then
+ Xapi_vm_lifecycle.force_state_reset ~__context ~self:vm ~value:`Halted
+ )
+ resident_on_vms
+ end
+ )
+ hosts;
+
+ (* If something has changed then we'd better refresh the pool status *)
+ if !reset_vms <> [] then ignore(update_pool_status ~__context);
+
+ (* At this point failed protected agile VMs are Halted, not resident_on anywhere *)
+
+ let all_protected_vms = all_protected_vms ~__context in
+
+ let plan, plan_is_complete =
+ try
+ if Xapi_fist.simulate_planner_failure () then failwith "fist_simulate_planner_failure";
+ (* CA-23981: if the pool-pre-ha-vm-restart hook exists AND if we're about to auto-start some VMs then
+ call the script hook first and then recompute the plan aftwards. Note that these VMs may either
+ be protected or best-effort. For the protected ones we assume that these are included in the VM
+ restart plan-- we ignore the possibility that the planner may fail here (even through there is some
+ last-ditch code later to perform best-effort VM.starts). This is ok since it should never happen and
+ this particular hook is really a 'best-effort' integration point since it conflicts with the overcommit
+ protection.
+ For the best-effort VMs we call the script
+ when we have reset some VMs to halted (no guarantee there is enough resource but better safe than sorry) *)
+ let plan, config, vms_not_restarted, non_agile_protected_vms_exist = compute_restart_plan ~__context ~all_protected_vms n in
+ let plan, config, vms_not_restarted, non_agile_protected_vms_exist =
+ if true
+ && Xapi_hooks.pool_pre_ha_vm_restart_hook_exists ()
+ && (plan <> [] || !reset_vms <> []) then begin
+ (* We're about to soak up some resources for 'Level 1' VMs somewhere; before we do that give 'Level 2' VMs a shot *)
+ (* Whatever this script does we don't let it break our restart thread *)
+ begin
+ try
+ Xapi_hooks.pool_pre_ha_vm_restart_hook ~__context
+ with e ->
+ error "pool-pre-ha-vm-restart-hook failed: %s: continuing anyway" (ExnHelper.string_of_exn e)
+ end;
+ debug "Recomputing restart plan to take into account new state of the world after running the script";
+ compute_restart_plan ~__context ~all_protected_vms n
+ end else plan, config, vms_not_restarted, non_agile_protected_vms_exist (* nothing needs recomputing *)
+ in
+
+ (* If we are undercommitted then vms_not_restarted = [] and plan will include all offline protected_vms *)
+ let plan_is_complete = vms_not_restarted = [] in
+ plan, plan_is_complete
+ with e ->
+ error "Caught unexpected exception in HA planner: %s" (ExnHelper.string_of_exn e);
+ [], false in
+
+ (* Send at most one alert per protected VM failure *)
+ let consider_sending_failed_alert_for vm =
+ debug "We failed to restart protected VM %s: considering sending an alert" (Ref.string_of vm);
+ if not(Hashtbl.mem restart_failed vm) then begin
+ Hashtbl.replace restart_failed vm ();
+ let obj_uuid = Db.VM.get_uuid ~__context ~self:vm in
+ Xapi_alert.add ~name:Api_messages.ha_protected_vm_restart_failed ~priority:1L ~cls:`VM ~obj_uuid ~body:""
+ end in
+
+ (* execute the plan *)
+ Helpers.call_api_functions ~__context
+ (fun rpc session_id ->
+
+ (* Helper function to start a VM somewhere. If the HA overcommit protection stops us then disable it and try once more.
+ Returns true if the VM was restarted and false otherwise. *)
+ let restart_vm vm ?host () =
+ let go () =
+
+ if Xapi_fist.simulate_restart_failure () then begin
+ match Random.int 3 with
+ | 0 -> raise (Api_errors.Server_error(Api_errors.ha_operation_would_break_failover_plan, []))
+ | 1 -> raise (Api_errors.Server_error("FIST: unexpected exception", []))
+ | 2 -> ()
+ end;
+
+ (* If we tried before and failed, don't retry again within 2 minutes *)
+ let attempt_restart =
+ if Hashtbl.mem last_start_attempt vm
+ then Unix.gettimeofday () -. (Hashtbl.find last_start_attempt vm) > 120.
+ else true in
+
+ if attempt_restart then begin
+ Hashtbl.replace last_start_attempt vm (Unix.gettimeofday ());
+ match host with
+ | None -> Client.Client.VM.start rpc session_id vm false true
+ | Some h -> Client.Client.VM.start_on rpc session_id vm h false true
+ end else failwith (Printf.sprintf "VM: %s restart attempt delayed for 120s" (Ref.string_of vm)) in
+ try
+ go ();
+ true
+ with
+ | Api_errors.Server_error(code, params) when code = Api_errors.ha_operation_would_break_failover_plan ->
+ (* This should never happen since the planning code would always allow the restart of a protected VM... *)
+ error "Caught exception HA_OPERATION_WOULD_BREAK_FAILOVER_PLAN: setting pool as overcommitted and retrying";
+ mark_pool_as_overcommitted ~__context;
+ begin
+ try
+ go ();
+ true
+ with e ->
+ error "Caught exception trying to restart VM %s: %s" (Ref.string_of vm) (ExnHelper.string_of_exn e);
+ false
+ end
+ | e ->
+ error "Caught exception trying to restart VM %s: %s" (Ref.string_of vm) (ExnHelper.string_of_exn e);
+ false in
+
+ (* Build a list of bools, one per Halted protected VM indicating whether we managed to start it or not *)
+ let started =
+ if not plan_is_complete then begin
+ (* If the Pool is overcommitted the restart priority will make the difference between a VM restart or not,
+ while if we're undercommitted the restart priority only affects the timing slightly. *)
+ let all = List.filter (fun (_, r) -> r.API.vM_power_state = `Halted) all_protected_vms in
+ let all = List.sort by_restart_priority all in
+ warn "Failed to find plan to restart all protected VMs: falling back to simple VM.start in priority order";
+ List.map (fun (vm, _) -> vm, restart_vm vm ()) all
+ end else begin
+ (* Walk over the VMs in priority order, starting each on the planned host *)
+ let all = List.sort by_restart_priority (List.map (fun (vm, _) -> vm, Db.VM.get_record ~__context ~self:vm) plan) in
+ List.map (fun (vm, _) ->
+ vm, (if List.mem_assoc vm plan
+ then restart_vm vm ~host:(List.assoc vm plan) ()
+ else false)) all
+ end in
+ (* Perform one final restart attempt of any that weren't started. *)
+ let started = List.map (fun (vm, started) -> match started with
+ | true -> vm, true
+ | false -> vm, restart_vm vm ()) started in
+ (* Send an alert for any failed VMs *)
+ List.iter (fun (vm, started) -> if not started then consider_sending_failed_alert_for vm) started;
+
+ (* Forget about previously failed VMs which have gone *)
+ let vms_we_know_about = List.map fst started in
+ let gc_table tbl =
+ let vms_in_table = Hashtbl.fold (fun vm _ acc -> vm :: acc) tbl [] in
+ List.iter (fun vm -> if not(List.mem vm vms_we_know_about) then (debug "Forgetting VM: %s" (Ref.string_of vm); Hashtbl.remove tbl vm)) vms_in_table in
+ gc_table last_start_attempt;
+ gc_table restart_failed;
+
+ (* Consider restarting the best-effort VMs we *think* have failed (but we might get this wrong --
+ ok since this is 'best-effort'). NOTE we do not use the restart_vm function above as this will mark the
+ pool as overcommitted if an HA_OPERATION_WOULD_BREAK_FAILOVER_PLAN is received (although this should never
+ happen it's better safe than sorry) *)
+ List.iter
+ (fun vm ->
+ try
+ if Db.VM.get_power_state ~__context ~self:vm = `Halted
+ && Db.VM.get_ha_always_run ~__context ~self:vm
+ && Db.VM.get_ha_restart_priority ~__context ~self:vm = Constants.ha_restart_best_effort
+ then Client.Client.VM.start rpc session_id vm false true
+ with e ->
+ error "Failed to restart best-effort VM %s (%s): %s"
+ (Db.VM.get_uuid ~__context ~self:vm)
+ (Db.VM.get_name_label ~__context ~self:vm)
+ (ExnHelper.string_of_exn e)) !reset_vms
+
+ )
same VM twice during memory calculations to determine whether a given VM can start on a particular host..
*)
-let start ~__context ~vm ~start_paused:paused ~force =
+let start ~__context ~vm ~start_paused:paused ~force =
License_check.with_vm_license_check ~__context vm (fun () ->
- Local_work_queue.wait_in_line Local_work_queue.normal_vm_queue
- (Printf.sprintf "VM.start %s" (Context.string_of_task __context))
- (fun () ->
- Locking_helpers.with_lock vm
- (fun token () ->
- debug "start: making sure the VM really is halted";
- assert_power_state_is ~__context ~vm ~expected:`Halted;
-
- debug "start: checking that VM can run on this host";
- (* Message forwarding layer has guaranteed to set the last_boot record
- with the configuration it used to perform the memory check. *)
- let snapshot = Helpers.get_boot_record ~__context ~self:vm in
- (* Xapi_vm_helpers.assert_can_boot_here not required since the message_forwarding
- layer has already done it and it's very expensive on a slave *)
-
- assert_ha_always_run_is_true ~__context ~vm;
-
- (* check BIOS strings: set to generic values if empty *)
- let bios_strings = Db.VM.get_bios_strings ~__context ~self:vm in
- if bios_strings = [] then begin
- info "The VM's BIOS strings were not yet filled in. The VM is now made BIOS-generic.";
- Db.VM.set_bios_strings ~__context ~self:vm ~value:Xapi_globs.generic_bios_strings
- end;
+ Local_work_queue.wait_in_line Local_work_queue.normal_vm_queue
+ (Printf.sprintf "VM.start %s" (Context.string_of_task __context))
+ (fun () ->
+ Locking_helpers.with_lock vm
+ (fun token () ->
+ debug "start: making sure the VM really is halted";
+ assert_power_state_is ~__context ~vm ~expected:`Halted;
+
+ debug "start: checking that VM can run on this host";
+ (* Message forwarding layer has guaranteed to set the *)
+ (* last_boot record with the configuration it used to *)
+ (* perform the memory check. *)
+ let snapshot = Helpers.get_boot_record ~__context ~self:vm in
+ (* Xapi_vm_helpers.assert_can_boot_here not required *)
+ (* since the message_forwarding layer has already *)
+ (* done it and it's very expensive on a slave. *)
+ assert_ha_always_run_is_true ~__context ~vm;
- debug "start: bringing up domain in the paused state";
- Vmops.start_paused
- ~progress_cb:(TaskHelper.set_progress ~__context) ~pcidevs:None ~__context ~vm ~snapshot;
- delete_guest_metrics ~__context ~self:vm;
-
- let localhost = Helpers.get_localhost ~__context in
- Helpers.call_api_functions ~__context
- (fun rpc session_id -> Client.VM.atomic_set_resident_on rpc session_id vm localhost);
-
- if paused then
- Db.VM.set_power_state ~__context ~self:vm ~value:`Paused
- else (
- let domid = Helpers.domid_of_vm ~__context ~self:vm in
- debug "start: unpausing domain (domid %d)" domid;
- with_xc_and_xs
- (fun xc xs ->
- Domain.unpause ~xc domid;
- );
-(*
- (* hack to get xmtest to work *)
- if Pool_role.is_master () then
- Monitor_master.update_all ~__context (Monitor.read_all_dom0_stats ());
-*)
- Db.VM.set_power_state ~__context ~self:vm ~value:`Running
- )
-) ())
- )
+ (* check BIOS strings: set to generic values if empty *)
+ let bios_strings = Db.VM.get_bios_strings ~__context ~self:vm in
+ if bios_strings = [] then begin
+ info "The VM's BIOS strings were not yet filled in. The VM is now made BIOS-generic.";
+ Db.VM.set_bios_strings ~__context ~self:vm ~value:Xapi_globs.generic_bios_strings
+ end;
+
+ debug "start: bringing up domain in the paused state";
+ Vmops.start_paused
+ ~progress_cb:(TaskHelper.set_progress ~__context) ~pcidevs:None ~__context ~vm ~snapshot;
+ delete_guest_metrics ~__context ~self:vm;
+
+ let localhost = Helpers.get_localhost ~__context in
+ Helpers.call_api_functions ~__context
+ (fun rpc session_id -> Client.VM.atomic_set_resident_on rpc session_id vm localhost);
+
+ if paused then
+ Db.VM.set_power_state ~__context ~self:vm ~value:`Paused
+ else (
+ let domid = Helpers.domid_of_vm ~__context ~self:vm in
+ debug "start: unpausing domain (domid %d)" domid;
+ with_xc_and_xs
+ (fun xc xs -> Domain.unpause ~xc domid);
+ (*
+ (* hack to get xmtest to work *)
+ if Pool_role.is_master () then
+ Monitor_master.update_all ~__context (Monitor.read_all_dom0_stats ());
+ *)
+ Db.VM.set_power_state ~__context ~self:vm ~value:`Running
+ )
+ ) ()))
(** For VM.start_on and VM.resume_on the message forwarding layer should only forward here
if 'host' = localhost *)
let get_info vm = get_uuid vm, get_name vm, get_power_state vm
let start vm =
- get_task (Remote.Async.VM.start ~session_id:!session_id
- ~start_paused:true ~vm)
+ get_task
+ (Remote.Async.VM.start
+ ~session_id:!session_id
+ ~start_paused:true
+ ~vm)
let unpause vm = Remote.VM.unpause ~rpc ~session_id:!session_id ~vm
let pause vm = Remote.VM.pause ~rpc ~session_id:!session_id ~vm
projects / xcp / xen-api.git / commitdiff