[RFC]: Add a 'floppy' VBD type (take #2)

ocaml/client_records/record_util.ml

@@ -324,6 +324,7 @@ let string_to_vbd_type s =
 	match String.lowercase s with
 		| "cd" -> `CD
 		| "disk" -> `Disk
+		| "floppy" -> `Floppy
 		| _ -> raise (Record_failure ("Expected 'CD' or 'Disk', got "^s))
 
 let power_to_string h =

ocaml/client_records/records.ml

@@ -1158,7 +1158,7 @@ let vbd_record rpc session_id vbd =
       ~set:(fun boot -> Client.VBD.set_bootable rpc session_id vbd (safe_bool_of_string "bootable" boot)) ();
     make_field ~name:"mode" ~get:(fun () -> match (x ()).API.vBD_mode with `RO -> "RO" | `RW -> "RW") 
       ~set:(fun mode -> Client.VBD.set_mode rpc session_id vbd (Record_util.string_to_vbd_mode mode)) ();
-    make_field ~name:"type" ~get:(fun () -> match (x ()).API.vBD_type with `CD -> "CD" | `Disk -> "Disk")
+    make_field ~name:"type" ~get:(fun () -> match (x ()).API.vBD_type with `CD -> "CD" | `Disk -> "Disk" | `Floppy -> "Floppy")
       ~set:(fun ty -> Client.VBD.set_type rpc session_id vbd (Record_util.string_to_vbd_type ty)) ();
     make_field ~name:"unpluggable" ~get:(fun () -> string_of_bool (x ()).API.vBD_unpluggable)
       ~set:(fun unpluggable -> Client.VBD.set_unpluggable rpc session_id vbd (safe_bool_of_string "unpluggable" unpluggable)) ();

ocaml/idl/datamodel.ml

@@ -5738,7 +5738,8 @@ let vbd_mode = Enum ("vbd_mode", [ "RO", "only read-only access will be allowed"
 
 let vbd_type = Enum ("vbd_type",
 		     [ "CD", "VBD will appear to guest as CD"; 
-		       "Disk", "VBD will appear to guest as disk" ])
+		       "Disk", "VBD will appear to guest as disk";
+                       "Floppy", "VBD will appear as a floppy"])
 
 let vbd_operations =
   Enum ("vbd_operations", 

ocaml/xapi/import.ml

@@ -859,7 +859,7 @@ module VBD : HandlerTools = struct
 
 			let vbd_record = { vbd_record with API.vBD_VM = vm } in
 			match vbd_record.API.vBD_type, exists vbd_record.API.vBD_VDI state.table with
-			| `CD, false ->
+			| `CD, false | `Floppy, false  ->
 				if original_vm.API.vM_power_state <> `Suspended then
 					Create { vbd_record with API.vBD_VDI = Ref.null; API.vBD_empty = true }  (* eject *)
 				else

ocaml/xapi/xapi_vbd.ml

@@ -133,15 +133,18 @@ let create  ~__context ~vM ~vDI ~userdevice ~bootable ~mode ~_type ~unpluggable
 	| _ ->
 
 	Mutex.execute autodetect_mutex (fun () ->
-		let possibilities = Xapi_vm_helpers.allowed_VBD_devices ~__context ~vm:vM in
+		let possibilities = Xapi_vm_helpers.allowed_VBD_devices ~__context ~vm:vM ~_type in
 
 		if not (valid_device userdevice) || (userdevice = "autodetect" && possibilities = []) then
 			raise (Api_errors.Server_error (Api_errors.invalid_device,[userdevice]));
 
 		(* Resolve the "autodetect" into a fixed device name now *)
 		let userdevice =
 			if userdevice = "autodetect"
-			then string_of_int (Device_number.to_disk_number (List.hd possibilities)) (* already checked for [] above *)
+			then match _type with
+				 (* already checked for [] above *)
+				 | `Floppy -> Device_number.to_linux_device (List.hd possibilities)
+				 | `CD | `Disk -> string_of_int (Device_number.to_disk_number (List.hd possibilities))
 			else userdevice
 		in
 

ocaml/xapi/xapi_vm.ml

@@ -725,7 +725,7 @@ let get_possible_hosts ~__context ~vm =
 	let snapshot = Db.VM.get_record ~__context ~self:vm in
 	get_possible_hosts_for_vm ~__context ~vm ~snapshot
 
-let get_allowed_VBD_devices ~__context ~vm = List.map (fun d -> string_of_int (Device_number.to_disk_number d)) (allowed_VBD_devices ~__context ~vm)
+let get_allowed_VBD_devices ~__context ~vm = List.map (fun d -> string_of_int (Device_number.to_disk_number d)) (allowed_VBD_devices ~__context ~vm ~_type:`Disk)
 let get_allowed_VIF_devices = allowed_VIF_devices
 
 (* Undocumented Rio message, deprecated in favour of standard VM.clone *)

ocaml/xapi/xapi_vm_helpers.ml

@@ -822,6 +822,7 @@ let allowed_VBD_devices_HVM            = vbd_inclusive_range true 0 3
 let allowed_VBD_devices_HVM_PP         = vbd_inclusive_range true 0 15
 let allowed_VBD_devices_PV             = vbd_inclusive_range false 0 15
 let allowed_VBD_devices_control_domain = vbd_inclusive_range false 0 255
+let allowed_VBD_devices_HVM_floppy     = List.map (fun x -> Device_number.make (Device_number.Floppy, x, 0)) (inclusive_range 0 1)
 
 let allowed_VIF_devices_HVM    = vif_inclusive_range 0 3
 let allowed_VIF_devices_HVM_PP = vif_inclusive_range 0 6
@@ -846,19 +847,21 @@ let all_used_VBD_devices ~__context ~self =
 
 	List.concat (List.map possible_VBD_devices_of_string existing_devices)
 
-let allowed_VBD_devices ~__context ~vm =
+let allowed_VBD_devices ~__context ~vm ~_type =
 	let is_hvm = Helpers.will_boot_hvm ~__context ~self:vm in
 	let is_control_domain = Db.VM.get_is_control_domain ~__context ~self:vm in
 	let is_pp =
 		try
 			let guest_metrics = Db.VM.get_guest_metrics ~__context ~self:vm in
 			(Db.VM_guest_metrics.get_PV_drivers_version ~__context ~self:guest_metrics) <> []
 		with _ -> false in
-	let all_devices = match is_hvm,is_pp,is_control_domain with
-		| false, _, true  -> allowed_VBD_devices_control_domain
-		| false, _, false -> allowed_VBD_devices_PV
-		| true, false, _  -> allowed_VBD_devices_HVM
-		| true, true, _   -> allowed_VBD_devices_HVM_PP
+	let all_devices = match is_hvm,is_pp,is_control_domain,_type with
+		| true, _, _, `Floppy  -> allowed_VBD_devices_HVM_floppy
+		| false, _, _, `Floppy -> [] (* floppy is not supported on PV *)
+		| false, _, true, _    -> allowed_VBD_devices_control_domain
+		| false, _, false, _   -> allowed_VBD_devices_PV
+		| true, false, _, _    -> allowed_VBD_devices_HVM
+		| true, true, _, _     -> allowed_VBD_devices_HVM_PP
 	in
 	(* Filter out those we've already got VBDs for *)
 	let used_devices = all_used_VBD_devices ~__context ~self:vm in

ocaml/xapi/xapi_xenops.ml

@@ -443,7 +443,10 @@ module MD = struct
 			position = Some device_number;
 			mode = if vbd.API.vBD_mode = `RO then ReadOnly else ReadWrite;
 			backend = disk_of_vdi ~__context ~self:vbd.API.vBD_VDI;
-			ty = if vbd.API.vBD_type = `Disk then Disk else CDROM;
+			ty = (match vbd.API.vBD_type with
+				| `Disk -> Disk
+				| `CD -> CDROM
+				| `Floppy -> Floppy);
 			unpluggable = vbd.API.vBD_unpluggable;
 			extra_backend_keys = backend_kind_keys;
 			extra_private_keys = [];
@@ -1306,9 +1309,17 @@ let update_vbd ~__context (id: (string * string)) =
 					let vbds = Db.VM.get_VBDs ~__context ~self:vm in
 					let vbdrs = List.map (fun self -> self, Db.VBD.get_record ~__context ~self) vbds in
 					let linux_device = snd id in
-					let disk_number = Device_number.of_linux_device (snd id) |> Device_number.to_disk_number |> string_of_int in
+					let device_number = Device_number.of_linux_device linux_device in
+					(* only try matching against disk number if the device is not a floppy (as "0" shouldn't match "fda") *)
+					let disk_number =
+						match Device_number.spec device_number with
+							| (Device_number.Ide,_,_)
+							| (Device_number.Xen,_,_) -> Some (device_number |> Device_number.to_disk_number |> string_of_int)
+							| _ -> None in
 					debug "VM %s VBD userdevices = [ %s ]" (fst id) (String.concat "; " (List.map (fun (_,r) -> r.API.vBD_userdevice) vbdrs));
-					let vbd, vbd_r = List.find (fun (_, vbdr) -> vbdr.API.vBD_userdevice = linux_device || vbdr.API.vBD_userdevice = disk_number) vbdrs in
+					let vbd, vbd_r = List.find (fun (_, vbdr) -> vbdr.API.vBD_userdevice = linux_device || 
+																(Opt.is_some disk_number && vbdr.API.vBD_userdevice = Opt.unbox disk_number)) vbdrs in
+					debug "VBD %s.%s matched device %s" (fst id) (snd id) vbd_r.API.vBD_userdevice;
 					Opt.iter
 						(fun (vb, state) ->
 							let currently_attached = state.plugged || state.active in