From: Xen hg user Date: Wed, 26 Jan 2011 17:39:04 +0000 (+0000) Subject: [whitespace] Conservatively corrects the whitespace for a small number of functions... X-Git-Url: http://xenbits.xensource.com/gitweb?a=commitdiff_plain;h=33714c899bedddba4750af05c000361eddd031e1;p=xcp%2Fxen-api.git [whitespace] Conservatively corrects the whitespace for a small number of functions that invoke VM start, in preparation for further patches that will add parameters to VM start. Signed-off-by: Jonathan Knowles Proof that this patch introduces no semantic changes: camlp4o -printer o -no_comments $file: ocaml/guest_installer/operations.ml 398ff818ee6c030d38bc6b76fa7385a5 - 398ff818ee6c030d38bc6b76fa7385a5 - PASS ocaml/lvhdrt/tc_8682.ml 7ed322d06bce9560709e6dbff008b92b - 7ed322d06bce9560709e6dbff008b92b - PASS ocaml/multipathrt/iscsi_utils.ml a13f2e09112de6bbc4573eb99d97a14e - a13f2e09112de6bbc4573eb99d97a14e - PASS ocaml/perftest/createpool.ml c5d540752831a6f4ea90ebab927aebe0 - c5d540752831a6f4ea90ebab927aebe0 - PASS ocaml/perftest/createVM.ml 9c61c2e5a870bbb23fa4963e16d213f1 - 9c61c2e5a870bbb23fa4963e16d213f1 - PASS ocaml/perftest/tests.ml 3f42d787e9d5453af839f073a203cdf2 - 3f42d787e9d5453af839f073a203cdf2 - PASS ocaml/toplevel/testscript.ml f5726b371208812719d271db11b175b5 - f5726b371208812719d271db11b175b5 - PASS ocaml/toplevel/vm_start.ml 0b438921a4e7d383f8227d39916d0a74 - 0b438921a4e7d383f8227d39916d0a74 - PASS ocaml/xapi/message_forwarding.ml 0c15667c3ce05fd5a7b6b9c62c2b30cc - 0c15667c3ce05fd5a7b6b9c62c2b30cc - PASS ocaml/xapimon/xapimon.ml 4ae10b335aac69bd38f2868c68e4daf6 - 4ae10b335aac69bd38f2868c68e4daf6 - PASS ocaml/xapi/quicktest_lifecycle.ml 4cb982e5ef773a0b9e532cf63d113ea4 - 4cb982e5ef773a0b9e532cf63d113ea4 - PASS ocaml/xapi/quicktest.ml 4ae53162b079db97eaafb4b5aeeaaae9 - 4ae53162b079db97eaafb4b5aeeaaae9 - PASS ocaml/xapi/xapi_ha_vm_failover.ml 230ee174e12e54801b332ca06ed7b055 - 230ee174e12e54801b332ca06ed7b055 - PASS ocaml/xapi/xapi_vm.ml 83642a93962b2ae7da82b0aad1389ec7 - 83642a93962b2ae7da82b0aad1389ec7 - PASS --- diff --git a/ocaml/guest_installer/operations.ml b/ocaml/guest_installer/operations.ml index dab93395..4f54bffe 100644 --- a/ocaml/guest_installer/operations.ml +++ b/ocaml/guest_installer/operations.ml @@ -82,7 +82,7 @@ let vm_construct session_id distro params = 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" diff --git a/ocaml/lvhdrt/tc_8682.ml b/ocaml/lvhdrt/tc_8682.ml index 90f7a62e..e1bcdf13 100644 --- a/ocaml/lvhdrt/tc_8682.ml +++ b/ocaml/lvhdrt/tc_8682.ml @@ -34,7 +34,7 @@ let really_run rpc session () = 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 @@ -56,23 +56,23 @@ let really_run rpc session () = 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 () diff --git a/ocaml/multipathrt/iscsi_utils.ml b/ocaml/multipathrt/iscsi_utils.ml index d9fc9b1d..e4ba43b0 100644 --- a/ocaml/multipathrt/iscsi_utils.ml +++ b/ocaml/multipathrt/iscsi_utils.ml @@ -36,41 +36,41 @@ let assert_sr_exists rpc session_id sr name = 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 *) diff --git a/ocaml/perftest/createVM.ml b/ocaml/perftest/createVM.ml index 06cfb2ba..39893876 100644 --- a/ocaml/perftest/createVM.ml +++ b/ocaml/perftest/createVM.ml @@ -31,35 +31,35 @@ let find_iscsi_iso session_id = (** 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 diff --git a/ocaml/perftest/createpool.ml b/ocaml/perftest/createpool.ml index d76c860b..b9f7b4ba 100644 --- a/ocaml/perftest/createpool.ml +++ b/ocaml/perftest/createpool.ml @@ -173,260 +173,260 @@ let iscsi_vm_iso_must_exist session_id = 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; diff --git a/ocaml/perftest/tests.ml b/ocaml/perftest/tests.ml index ce065548..1003d92b 100644 --- a/ocaml/perftest/tests.ml +++ b/ocaml/perftest/tests.ml @@ -40,22 +40,29 @@ let subtest_string key tag = 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 *) diff --git a/ocaml/toplevel/testscript.ml b/ocaml/toplevel/testscript.ml index a23ace2d..2cbee6ba 100644 --- a/ocaml/toplevel/testscript.ml +++ b/ocaml/toplevel/testscript.ml @@ -35,21 +35,21 @@ let vmop_to_string = function | 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" diff --git a/ocaml/toplevel/vm_start.ml b/ocaml/toplevel/vm_start.ml index 17e45dbc..3e74bdef 100644 --- a/ocaml/toplevel/vm_start.ml +++ b/ocaml/toplevel/vm_start.ml @@ -14,8 +14,8 @@ 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 diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 10e2be48..d0a6fcc6 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -1023,74 +1023,96 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct ) ) - 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); diff --git a/ocaml/xapi/quicktest.ml b/ocaml/xapi/quicktest.ml index 6ba474ac..91f06b16 100644 --- a/ocaml/xapi/quicktest.ml +++ b/ocaml/xapi/quicktest.ml @@ -267,72 +267,72 @@ let compare_snapshots session_id test one two = (* 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) @@ -379,145 +379,145 @@ let rec wait_for_task_complete session_id task = (* 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 *) diff --git a/ocaml/xapi/quicktest_lifecycle.ml b/ocaml/xapi/quicktest_lifecycle.ml index 456111a5..f1ee0b1c 100644 --- a/ocaml/xapi/quicktest_lifecycle.ml +++ b/ocaml/xapi/quicktest_lifecycle.ml @@ -109,91 +109,91 @@ open Client 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 diff --git a/ocaml/xapi/xapi_ha_vm_failover.ml b/ocaml/xapi/xapi_ha_vm_failover.ml index 1e944f10..a65a93f4 100644 --- a/ocaml/xapi/xapi_ha_vm_failover.ml +++ b/ocaml/xapi/xapi_ha_vm_failover.ml @@ -433,215 +433,215 @@ let last_start_attempt : (API.ref_VM, float) Hashtbl.t = Hashtbl.create 10 (* 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 + + ) diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 8e5e188f..5c9839b3 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -212,59 +212,57 @@ let unpause ~__context ~vm = 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 *) diff --git a/ocaml/xapimon/xapimon.ml b/ocaml/xapimon/xapimon.ml index 12f4bbb2..79347adb 100644 --- a/ocaml/xapimon/xapimon.ml +++ b/ocaml/xapimon/xapimon.ml @@ -122,8 +122,11 @@ module Fct = functor(Remote: API.API) -> struct 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