Fix the tests

test/ftests.ml

@@ -62,7 +62,7 @@ module Dummy = struct
 		let pidfile = Printf.sprintf "/tmp/vhdd.pid.%d.%s" !counter host_id in
 		let logfile = Printf.sprintf "/tmp/vhdd.log.%d.%s" !counter host_id in
 		let errfile = Printf.sprintf "/tmp/vhdd.err.%d.%s" !counter host_id in
-
+		let start = Unix.gettimeofday () in
 		let args = [
 			"-dummy";
 			"-dummydir"; "/tmp/dummytest";
@@ -90,19 +90,27 @@ module Dummy = struct
 		  failwith (Printf.sprintf "Signaled: %d" x)
 		| Unix.WSTOPPED x ->
 		  failwith (Printf.sprintf "Stopped: %d" x));
-		Thread.delay 0.5;
-		let ic = open_in pidfile in
-		let pid_str = input_line ic in
-		let pid = int_of_string pid_str in
+		let pid = 
+		  let rec inner () =
+		    if Unix.gettimeofday () -. start > 10.0 then failwith "Failed to get pid";
+		    try
+		      let ic = open_in pidfile in
+		      let pid_str = input_line ic in
+		      int_of_string pid_str
+		    with _ ->
+		      inner ()
+		  in inner ()
+		in
 		let myrpc call = Xcp_client.xml_http_rpc ~srcstr:"ftests" ~dststr:"storage" 
 		  (fun () -> Printf.sprintf "http://127.0.0.1:%d/lvmnew" port) call 
 		in
 		let myintclient = Int_client.get {h_uuid="null"; h_ip=Some "127.0.0.1"; h_port=port} in
 		let module Intclient = (val myintclient : Int_client.CLIENT) in
 		let client = (module (Storage_interface.Client(struct let rpc call = myrpc call end)) : CLIENT) in
-		let rec wait_for_start total =
+		let rec wait_for_start () =
 			try
-				if total > 100 then begin
+			  let now = Unix.gettimeofday () in
+				if now -. start > 10.0 then begin
 				  debug "Error waiting for vhdd to start";
 				  let log = Unixext.string_of_file logfile in
 				  let stderr = Unixext.string_of_file errfile in
@@ -115,12 +123,9 @@ module Dummy = struct
 				debug "Got here...";
 				ignore(Client.SR.list ~dbg:"wait_for_start");
 			with e ->
-			        debug "Caught exception: %s" (Printexc.to_string e);
-			        debug "Backtrace: %s" (Printexc.get_backtrace ());
-				Thread.delay 0.1;
-				wait_for_start (total+1)
+				wait_for_start ()
 		in
-		wait_for_start 0;
+		wait_for_start ();
 
 		{ pid = Some pid;
 		  errfile = errfile;
@@ -131,11 +136,23 @@ module Dummy = struct
 		  intclient = myintclient; }
 
 	let kill_vhdd vhdd =
-	        debug "Killing vhdd";
+	  debug "Killing vhdd";
+	  let rec wait n pid =
+	    try
+	      Unix.kill pid 0;
+	      wait (n+1) pid;
+	    with
+	    | Unix.Unix_error (Unix.ESRCH,_,_) ->
+	      debug "Finished after %d" n;
+	      ()
+	    | e ->
+	      raise e
+	  in
 	  let module Intclient = (val vhdd.intclient : Int_client.CLIENT) in
 	  (try Intclient.Debug.die ~restart:false with e -> debug "Caught exception %s" (Printexc.to_string e));
-		(*match vhdd.pid with Some h -> ignore(Forkhelpers.waitpid h) | None -> *)
-		  Thread.delay 0.5
+	  match vhdd.pid with
+	  | Some h -> wait 0 h
+	  | None -> Thread.delay 0.5
 
 	let create_and_attach vhdds =
 		let master = List.hd vhdds in
@@ -237,7 +254,7 @@ module Real = struct
 		Client.SR.create ~dbg ~sr ~device_config:master_device_config ~physical_size:0L;
 		Client.SR.attach ~dbg ~sr ~device_config:master_device_config;
 
-		Thread.delay 0.5;
+(*		Thread.delay 0.5;*)
 
 		List.iter (fun slave ->
 		  let module SC = (val slave.client : CLIENT) in
@@ -467,15 +484,15 @@ let restart_master state =
 	(try Intclient.Debug.die ~restart:true with _ -> ());
 	let rec wait_for_new_pid () =
 		try
-			Thread.delay 0.1;
+(*			Thread.delay 0.1;*)
 			let newpid = Intclient.Debug.get_pid () in
 			if newpid = oldpid then wait_for_new_pid ()
 		with _ ->
 			wait_for_new_pid ()
 	in wait_for_new_pid ();
 
 	let rec wait_for_ready () =
-	  Thread.delay 0.1;
+(*	  Thread.delay 0.1;*)
 	  try 
 	    if not (Intclient.Debug.get_ready ())
 	    then wait_for_ready ()
@@ -487,7 +504,7 @@ let restart_master state =
 
 	let rec wait_for_attach_finished () =
 		try
-			Thread.delay 0.1;
+(*			Thread.delay 0.1;*)
 			let attach_finished = Intclient.Debug.get_attach_finished ~sr:state.sr in
 			if not attach_finished then wait_for_attach_finished ()
 		with _ -> wait_for_attach_finished ()
@@ -1779,7 +1796,7 @@ let _ =
 
 	(Real.uri := Printf.sprintf "/%s" !backend);
 
-	Debug.log_to_stdout ();
+(*	Debug.log_to_stdout ();*)
 
 	Real.hosts := String.split ',' !hosts;
 

vhd/int_client_utils.ml

@@ -15,7 +15,7 @@ let rec slave_retry_loop context allowed_errors (f : (module Int_client.CLIENT)
       let client = Int_client.get h in
       f client
   with
-  | IntError(e,args) as exn ->
+  | Int_rpc.IntError(e,args) as exn ->
     if List.mem e allowed_errors
     then (debug "Ignorning allowed error '%s' in slave_retry_loop" e; raise exn)
     else begin
@@ -39,11 +39,11 @@ let rec master_retry_loop context allowed_errors bad_errors f metadata host =
   try
     let attached_hosts = Slave_sr_attachments.get_attached_hosts context metadata in
     if not (List.exists (fun ssa -> ssa.ssa_host.h_uuid=host.h_uuid) attached_hosts) then
-      raise (IntError(e_sr_not_attached,[host.h_uuid]));
+      raise (Int_rpc.IntError(e_sr_not_attached,[host.h_uuid]));
     let client = Int_client.get host in 
     f client
   with
-  | IntError(e,args) as exn ->
+  | Int_rpc.IntError(e,args) as exn ->
     if List.mem e bad_errors then begin
       error "Bad error caught: not continuing";
       raise exn

vhd/int_rpc.ml

@@ -3,6 +3,8 @@ open Int_types
 type vdi = Storage_interface.vdi
 type sr = Storage_interface.sr
 
+exception IntError of (string * (string list))
+
 type lock = string
 
 module SR = struct

vhd/int_types.ml

@@ -1,7 +1,5 @@
 open Camldm
 
-exception IntError of (string * (string list))
-
 let e_not_attached = "not_attached"
 let e_not_activated = "not_activated"
 let e_sr_not_attached = "host_not_attached"

vhd/locking.ml

@@ -45,7 +45,7 @@ let get_leaf_info metadata vdi_location =
 	try
 		Hashtbl.find metadata.m_data.m_id_to_leaf_mapping vdi_location
 	with Not_found ->
-		raise (IntError (e_unknown_location, [vdi_location]))
+		raise (Int_rpc.IntError (e_unknown_location, [vdi_location]))
 
 let set_leaf_info metadata vdi_location leaf_info =
 	Hashtbl.replace metadata.m_data.m_id_to_leaf_mapping vdi_location leaf_info
@@ -112,7 +112,7 @@ let slave_attach_reattach context metadata host vdi_location rw protected_fn =
 
 let slave_attach_unlock context metadata host vdi_location protected_fn =
 	with_leaf_op context metadata vdi_location OpDetaching (fun leaf_info -> 
-		let e = IntError(e_not_attached,[vdi_location]) in
+		let e = Int_rpc.IntError(e_not_attached,[vdi_location]) in
 		let leaf_info = update_leaf context metadata vdi_location (fun leaf_info ->
 			let new_attachment =
 				match leaf_info.attachment with
@@ -154,35 +154,35 @@ let slave_activate context metadata host vdi_location is_reactivate =
 				| Some (ActiveRW host'), _ ->
 					  if is_reactivate then begin
 						  if host<>host' then
-							  raise (IntError (e_vdi_active_elsewhere, [vdi_location]))
+							  raise (Int_rpc.IntError (e_vdi_active_elsewhere, [vdi_location]))
 						  else
 							  leaf_info
 					  end else
-						  raise (IntError (e_vdi_active_elsewhere, [vdi_location]))
+						  raise (Int_rpc.IntError (e_vdi_active_elsewhere, [vdi_location]))
 
 				| None, Some (AttachedRW hosts) ->
 					  let israw = match leaf_info.leaf with | PRaw _ -> true | PVhd _ -> false in
 					  if not (List.mem host hosts) then 
-						  raise (IntError (e_vdi_not_attached, [vdi_location]));
+						  raise (Int_rpc.IntError (e_vdi_not_attached, [vdi_location]));
 					  if israw 
 					  then {leaf_info with active_on = Some (ActiveRWRaw [host])} 
 					  else {leaf_info with active_on = Some (ActiveRW host)}
 
 				| Some (ActiveRWRaw acthosts), Some (AttachedRW atthosts) ->
 					  if not (List.mem host atthosts) then 
-						  raise (IntError (e_vdi_not_attached, [vdi_location]));
+						  raise (Int_rpc.IntError (e_vdi_not_attached, [vdi_location]));
 					  if not is_reactivate then (if (List.mem host acthosts) then failwith "Double activated!?");
 					  {leaf_info with active_on = Some (ActiveRWRaw (host::(List.filter (fun h -> h <> host) acthosts)))}
 
 				| _, None ->
-					  raise (IntError (e_vdi_not_attached, [vdi_location]))
+					  raise (Int_rpc.IntError (e_vdi_not_attached, [vdi_location]))
 
 				| _ -> 
 					  failwith "Unexpected attachment status!"))
 
 let slave_deactivate context metadata host vdi_location =
 	with_leaf_op context metadata vdi_location OpDeactivating (fun leaf_info -> 
-		let e = IntError(e_not_activated,[vdi_location]) in
+		let e = Int_rpc.IntError(e_not_activated,[vdi_location]) in
 		update_leaf context metadata vdi_location (fun leaf_info ->
 			match leaf_info.active_on with
 				| Some (ActiveRO hosts) ->

vhd/vhdMaster.ml

@@ -754,7 +754,7 @@ end
 		Slave_sr_attachments.slave_sr_detach_by_host_uuid context metadata host_uuid;
 		let leaves = Locking.get_all_leaf_infos context metadata in
 		List.iter (fun (k,leaf_info) ->
-			try VDI.slave_detach context metadata host_uuid k with IntError(e_not_attached,_) -> ()) leaves
+			try VDI.slave_detach context metadata host_uuid k with Int_rpc.IntError(e_not_attached,_) -> ()) leaves
 
 	let set_rolling_upgrade_finished context metadata =
 		fix_ctx context None;

vhd/vhdSlave.ml

@@ -151,9 +151,17 @@ module VDI = struct
 	    match current with
 	    | None ->
 	      let slave_attach_info = 
-		Int_client_utils.slave_retry_loop context [e_unknown_location] (fun client -> 
+		let x = Int_client_utils.slave_retry_loop context [e_unknown_location] (fun client -> 
 		  let module Client = (val client : Int_client.CLIENT) in
 		  Client.VDI.slave_attach ~host_uuid ~sr:sr_uuid ~vdi:id ~writable ~is_reattach:false) metadata in
+		if !Global.dummy 
+		then 
+		  { x with 
+		    sa_leaf_path = 
+		      Printf.sprintf "%s/%s" (Global.get_host_local_dummydir ()) x.sa_leaf_path
+		  }
+		else x
+	      in
 	      debug "Got response: leaf=%s" slave_attach_info.sa_leaf_path;
 
 	      with_master_approved_op context metadata id Attaching (fun () -> 
@@ -190,7 +198,7 @@ module VDI = struct
 			(* Make sure that we're attached... *)
 			Nmutex.execute context metadata.s_mutex "Making sure we're attached" (fun () ->
 				if not (Hashtbl.mem metadata.s_data.s_attached_vdis id) then
-					raise (IntError (e_not_attached, [id])));
+					raise (Int_rpc.IntError (e_not_attached, [id])));
 
 			commit_slave_attach_info_to_disk metadata.s_data.s_sr id sai;
 
@@ -286,14 +294,22 @@ module VDI = struct
 					let savi = Hashtbl.find metadata.s_data.s_attached_vdis id in
 					savi.savi_attach_info.sa_writable
 				with Not_found -> 
-					raise (IntError (e_not_attached, [id])))
+					raise (Int_rpc.IntError (e_not_attached, [id])))
 			in
 
 			(* We can't be detached because of the 'with_op' fn above, so now we're safe *)
 			let sai = 
 				Int_client_utils.slave_retry_loop context [] (fun client -> 
 				  let module Client = (val client : Int_client.CLIENT) in
-				  Client.VDI.slave_attach ~host_uuid:(Global.get_host_uuid ()) ~sr:metadata.s_data.s_sr ~vdi:id ~writable ~is_reattach:true) metadata in
+				  let x = Client.VDI.slave_attach ~host_uuid:(Global.get_host_uuid ()) ~sr:metadata.s_data.s_sr ~vdi:id ~writable ~is_reattach:true in
+				  if !Global.dummy 
+				  then 
+				    { x with 
+				      sa_leaf_path = 
+					Printf.sprintf "%s/%s" (Global.get_host_local_dummydir ()) x.sa_leaf_path
+				    }
+				  else x
+				) metadata in
 
 			debug "Got response: leaf=%s" sai.sa_leaf_path;
 
@@ -336,7 +352,7 @@ module VDI = struct
 
 							  Client.VDI.slave_detach ~host_uuid:(Global.get_host_uuid ()) 
 							    ~sr:metadata.s_data.s_sr ~vdi:id) metadata
-						with IntError(e,args) as exn ->
+						with Int_rpc.IntError(e,args) as exn ->
 							if e=e_not_attached
 							then debug "Ignoring not_attached exception from master"
 							else raise exn
@@ -451,7 +467,7 @@ module VDI = struct
 
 				  Client.VDI.slave_deactivate ~host_uuid:(Global.get_host_uuid ()) ~sr:metadata.s_data.s_sr ~vdi:id) metadata
 			with
-				| IntError(e,args) as exn ->
+				| Int_rpc.IntError(e,args) as exn ->
 					if (e=e_not_activated)
 					then debug "Ignoring not_activated error"
 					else raise exn
@@ -535,7 +551,15 @@ module VDI = struct
 		  Int_client_utils.slave_retry_loop context [] (fun client -> 
 		    let module Client = (val client : Int_client.CLIENT) in
 
-		    Client.VDI.get_slave_attach_info ~sr:sr_uuid ~vdi:id) metadata in
+		    let x = Client.VDI.get_slave_attach_info ~sr:sr_uuid ~vdi:id in
+		    if !Global.dummy 
+		    then 
+		      { x with 
+			sa_leaf_path = 
+			  Printf.sprintf "%s/%s" (Global.get_host_local_dummydir ()) x.sa_leaf_path
+		      }
+		    else x) metadata 
+		in
 		let arg = Jsonrpc.to_string (rpc_of_slave_attach_info slave_attach_info) in
 (*		let call = Smapi_client.make_call ~vdi_location:id device_config (Some metadata.s_data.s_sr) "vdi_attach_from_config" [ arg ] in
 		let str = Xml.to_string (Smapi_client.xmlrpc_of_call call) in

vhd/vhdsm.ml

@@ -503,10 +503,25 @@ module VDI = struct
 
 	let slave_reload ctx ~sr ~vdis =
 		let metadata = Attachments.gsm sr in
+		let vdis = 
+		  if !Global.dummy
+		  then List.map (fun (id,sai) ->
+		    (id,{sai with sa_leaf_path = 
+			Printf.sprintf "%s/%s" (Global.get_host_local_dummydir ()) sai.sa_leaf_path}))
+		    vdis
+		  else vdis
+		in
 		VhdSlave.VDI.slave_reload ctx metadata vdis
 
 	let slave_leaf_coalesce_stop_and_copy ctx ~sr ~vdi ~leaf_path ~new_leaf_path =
 		let metadata = Attachments.gsm sr in
+		let fix_path orig = 
+		  if !Global.dummy
+		  then Printf.sprintf "%s/%s" (Global.get_host_local_dummydir ()) orig
+		  else orig 
+		in
+		let leaf_path = fix_path leaf_path in
+		let new_leaf_path = fix_path new_leaf_path in
 		VhdSlave.VDI.slave_leaf_coalesce_stop_and_copy ctx metadata vdi leaf_path new_leaf_path
 
 	let external_clone ctx sr_uuid filename =
@@ -592,6 +607,7 @@ module Debug = struct
     Mutex.execute metadata.Vhd_types.s_mutex.Nmutex.m (fun () ->
       let v = Hashtbl.find metadata.Vhd_types.s_data.Vhd_types.s_attached_vdis vdi in
       let leaf_path = v.Vhd_types.savi_attach_info.Int_types.sa_leaf_path in
+      debug "XXX slave_get_leaf_vhduid: leaf_path=%s" leaf_path;
       Vhdutil.with_vhd leaf_path false (fun vhd -> 
 	Vhd.get_uid vhd))
   let write_junk ctx ~sr ~vdi ~size ~n ~current =