Merge pull request xapi-project#1199 from jonludlam/SCTX-1334

SCTX-1334 - reviewed by @djs55

ocaml/xapi/message_forwarding.ml

@@ -1369,6 +1369,10 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct
 			let local_fn = Local.VM.hard_shutdown ~vm in
 			with_vm_operation ~__context ~self:vm ~doc:"VM.hard_shutdown" ~op:`hard_shutdown
 				(fun () ->
+				  List.iter (fun (task,op) ->
+				    if op = `clean_shutdown then
+				      try Local.Task.cancel ~__context ~task:(Ref.of_string task) with _ -> ()) (Db.VM.get_current_operations ~__context ~self:vm);
+
 					(* If VM is actually suspended and we ask to hard_shutdown, we need to
 					   forward to any host that can see the VDIs *)
 					let policy =
@@ -1413,6 +1417,11 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct
 			let local_fn = Local.VM.hard_reboot ~vm in
 			with_vm_operation ~__context ~self:vm ~doc:"VM.hard_reboot" ~op:`hard_reboot
 				(fun () ->
+				  List.iter (fun (task,op) ->
+				    if op = `clean_reboot then
+				      try Local.Task.cancel ~__context ~task:(Ref.of_string task) with _ -> ()) (Db.VM.get_current_operations ~__context ~self:vm);
+
+
 					with_vbds_marked ~__context ~vm ~doc:"VM.hard_reboot" ~op:`attach
 						(fun vbds ->
 							with_vifs_marked ~__context ~vm ~doc:"VM.hard_reboot" ~op:`attach

ocaml/xapi/xapi_globs.ml

@@ -620,7 +620,7 @@ let pool_db_sync_interval = ref 300.
 let pool_data_sync_interval = ref 86400.
 
 let domain_shutdown_ack_timeout = ref 10.
-let domain_shutdown_total_timeout = ref 720.
+let domain_shutdown_total_timeout = ref 1200.
 
 (* The actual reboot delay will be a random value between base and base + extra *)
 let emergency_reboot_delay_base = ref 60.

ocaml/xapi/xapi_vm.ml

@@ -233,16 +233,23 @@ let hard_shutdown ~__context ~vm =
 	Xapi_xenops.shutdown ~__context ~self:vm None
 
 let clean_reboot ~__context ~vm =
-	Xapi_xenops.reboot ~__context ~self:vm (Some 1200.0)
+	Xapi_xenops.reboot ~__context ~self:vm (Some !Xapi_globs.domain_shutdown_total_timeout)
 
-let clean_shutdown ~__context ~vm =
+let clean_shutdown_with_timeout ~__context ~vm timeout =
 	Db.VM.set_ha_always_run ~__context ~self:vm ~value:false;
-	Xapi_xenops.shutdown ~__context ~self:vm (Some 1200.0)
+	Xapi_xenops.shutdown ~__context ~self:vm (Some timeout)
+
+let clean_shutdown ~__context ~vm =
+	clean_shutdown_with_timeout ~__context ~vm !Xapi_globs.domain_shutdown_total_timeout
 
 let shutdown ~__context ~vm =
 	begin
 		try
-			clean_shutdown ~__context ~vm 
+			let db_timeout = Db.VM.get_shutdown_delay ~__context ~self:vm in
+			clean_shutdown_with_timeout ~__context ~vm 
+				(if db_timeout > 0L 
+				 then Int64.to_float db_timeout
+				 else !Xapi_globs.domain_shutdown_total_timeout)
 		with e ->
 			warn "Failed to perform clean_shutdown on VM:%s due to exception %s. Now attempting hard_shutdown." (Ref.string_of vm) (Printexc.to_string e);
 			hard_shutdown ~__context ~vm

ocaml/xapi/xapi_vm_lifecycle.ml

@@ -105,13 +105,15 @@ let is_allowed_concurrently ~(op:API.vm_operations) ~current_ops =
 	and allowed_operations = (* a list of valid state -> operation *)
 		[ [`snapshot_with_quiesce], `snapshot;
 		  [`reverting],             `hard_shutdown;
-		  [`migrate_send],               `metadata_export;
+		  [`migrate_send],          `metadata_export;
 		  [`migrate_send],          `hard_shutdown;
 		  [`migrate_send],          `clean_shutdown;
-          [`migrate_send],          `hard_reboot;
+        	  [`migrate_send],          `hard_reboot;
 		  [`migrate_send],          `clean_reboot;
-          [`migrate_send],          `start;
-          [`migrate_send],          `start_on;] in
+        	  [`migrate_send],          `start;
+        	  [`migrate_send],          `start_on;
+		  [`clean_shutdown],        `hard_shutdown;
+		  [`clean_reboot],          `hard_reboot;] in
 	let state_machine () = 
 		let current_state = List.map snd current_ops in
 		List.exists (fun (state, transition) -> state = current_state && transition = op) allowed_operations

ocaml/xenops/domain.ml

@@ -304,12 +304,10 @@ let shutdown ~xc ~xs domid req =
 let shutdown_wait_for_ack (t: Xenops_task.t) ?(timeout=60.) ~xc ~xs domid req =
 	let di = Xenctrl.domain_getinfo xc domid in
 	let uuid = get_uuid ~xc domid in
-	if di.Xenctrl.Domain_info.hvm_guest then begin
-		if not (Xenctrl.hvm_check_pvdriver xc domid)
-		then begin
-			debug "VM = %s; domid = %d; HVM guest without PV drivers: not expecting any acknowledgement" (Uuid.to_string uuid) domid;
-			Xenctrl.domain_shutdown xc domid (shutdown_to_xc_shutdown req)
-		end
+	if ((di.Xenctrl.Domain_info.hvm_guest)
+	&& not (Xenctrl.hvm_check_pvdriver xc domid)) then begin
+		debug "VM = %s; domid = %d; HVM guest without PV drivers: not expecting any acknowledgement" (Uuid.to_string uuid) domid;
+		Xenctrl.domain_shutdown xc domid (shutdown_to_xc_shutdown req)
 	end else begin
 		debug "VM = %s; domid = %d; Waiting for PV domain to acknowledge shutdown request" (Uuid.to_string uuid) domid;
 		let path = control_shutdown ~xs domid in

ocaml/xenops/updates.ml

@@ -240,36 +240,34 @@ let t_of_rpc rpc =
 	  m = Mutex.create ();
 }
 
-
-let get dbg from timeout t =
+let get dbg ?(with_cancel=(fun _ f -> f ())) from timeout t =
 	let from = Opt.default U.initial from in
 	let cancel = ref false in
-	let id = Opt.map (fun timeout ->
-		Scheduler.one_shot (Scheduler.Delta timeout) dbg
+	let cancel_fn () =
+		debug "Cancelling: Update.get";
+		Mutex.execute t.m
 			(fun () ->
-				debug "Cancelling: Update.get after %d" timeout;
-				Mutex.execute t.m
-					(fun () ->
-						cancel := true;
-						Condition.broadcast t.c
-					)
-			)
+				cancel := true;
+				Condition.broadcast t.c
+			)  
+	in
+	let id = Opt.map (fun timeout ->
+		Scheduler.one_shot (Scheduler.Delta timeout) dbg cancel_fn
 	) timeout in
-	finally
-		(fun () ->
-			Mutex.execute t.m
-				(fun () ->
-					let is_empty (x,y,_) = x=[] && y=[] in
-
-					let rec wait () =
-						let result = U.get from t.u in
-						if is_empty result && not (!cancel) then 
-							begin Condition.wait t.c t.m; wait () end
-						else result
-					in
-					wait ()
-				)
-		) (fun () -> Opt.iter Scheduler.cancel id)
+	with_cancel cancel_fn (fun () -> 
+		finally (fun () ->
+			Mutex.execute t.m (fun () ->
+				let is_empty (x,y,_) = x=[] && y=[] in
+
+				let rec wait () =
+					let result = U.get from t.u in
+					if is_empty result && not (!cancel) then 
+					begin Condition.wait t.c t.m; wait () end
+					else result
+				in
+				wait ()
+			)
+		) (fun () -> Opt.iter Scheduler.cancel id))
 
 let last_id dbg t =
 	Mutex.execute t.m

ocaml/xenops/xenops_server_xen.ml

@@ -119,16 +119,24 @@ end
 let updates = Updates.empty ()
 
 let event_wait task timeout p =
-	let finished = ref false in
-	let success = ref false in
-	let event_id = ref None in
-	while not !finished do
-		let _, deltas, next_id = Updates.get (Printf.sprintf "event_wait task %s" task.Xenops_task.id) !event_id timeout updates in
-		if deltas = [] then finished := true;
-		List.iter (fun d -> if p d then (success := true; finished := true)) deltas;
-		event_id := Some next_id;
-	done;
-	!success
+	let start = Unix.gettimeofday () in
+	let rec inner remaining event_id =
+		if (remaining > 0.0) then begin
+			let _, deltas, next_id = Updates.get (Printf.sprintf "event_wait task %s" task.Xenops_task.id) 
+				~with_cancel:(Xenops_task.with_cancel task) event_id (Some (remaining |> ceil |> int_of_float)) updates in
+			let success = List.fold_left (fun acc d -> acc || (p d)) false deltas in
+			let finished = success || deltas = [] in
+			if not finished
+			then
+				let elapsed = Unix.gettimeofday () -. start in
+				inner (timeout -. elapsed) (Some next_id)
+			else
+				success
+		end else false
+	in 
+	let result = inner timeout None in
+	Xenops_task.check_cancelling task;
+	result
 
 let safe_rm xs path =
 	debug "xenstore-rm %s" path;
@@ -1140,7 +1148,7 @@ module VM = struct
 			) Oldest task vm
 
 	let wait_shutdown task vm reason timeout =
-		event_wait task (Some (timeout |> ceil |> int_of_float))
+		event_wait task timeout
 			(function
 				| Dynamic.Vm id when id = vm.Vm.id ->
 					debug "EVENT on our VM: %s" id;