X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=virt-p2v;h=922ad40a0b4465f9d68feba21734fbb84c522c86;hb=a8f18a057ab1c91edcf689420c19ce54a65be315;hp=3df66f34a0726d474269230bd45bdabf7261617f;hpb=e4ca3f4a174e04e1f67f9aace9473d7de79062e3;p=virt-p2v.git

diff --git a/virt-p2v b/virt-p2v
index 3df66f3..922ad40 100755
--- a/virt-p2v
+++ b/virt-p2v
@@ -51,6 +51,14 @@ type architecture =
   | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
   | OtherArch of string
   | UnknownArch
+type target_config = {
+  tgt_hypervisor : hypervisor option;	(* Remote hypervisor. *)
+  tgt_architecture : architecture;	(* Remote architecture. *)
+  tgt_memory : int;			(* Memory (megabytes). *)
+  tgt_vcpus : int;			(* Number of virtual CPUs. *)
+  tgt_mac_address : string;		(* MAC address. *)
+  tgt_libvirtd : bool;			(* True if libvirtd on remote. *)
+}
 
 (*----------------------------------------------------------------------*)
 (* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section.
@@ -87,12 +95,7 @@ let config_devices_to_send = ref None
 let config_root_filesystem = ref None
 
 (* Configuration of the target. *)
-let config_hypervisor = ref None
-let config_architecture = ref None
-let config_memory = ref None
-let config_vcpus = ref None
-let config_mac_address = ref None
-let config_libvirtd = ref None
+let config_target = ref None
 
 (* The name of the program as displayed in various places. *)
 let program_name = "virt-p2v"
@@ -114,6 +117,8 @@ let test_dialog_stages = false
 #load "mlnewt.cma";;
 #directory "+xml-light";;
 #load "xml-light.cma";;
+#directory "+libvirt";;
+#load "mllibvirt.cma";;
 
 open Unix
 open Printf
@@ -240,6 +245,101 @@ let failwith text =
   message_box "Error" text;
   exit 1
 
+(* Display a dialog with checkboxes, return the multiple selected items. *)
+let select_multiple ?stage ?(force_one = false) width title items =
+  with_newt (
+    fun () ->
+      open_centered_window ?stage width 20 title;
+
+      let entries =
+	List.mapi (
+	  fun i (label, handle, selected) ->
+	    let cb =
+	      Newt.checkbox 1 (i+1) label
+		(if selected then '*' else ' ') None in
+	    (handle, cb)
+	) items in
+
+      let ok = Newt.button 48 16 "  OK  " in
+
+      let vb =
+	if List.length entries > 10 then
+	  Some (Newt.vertical_scrollbar 58 1 10
+		  Newt_int.NEWT_COLORSET_WINDOW
+		  Newt_int.NEWT_COLORSET_ACTCHECKBOX)
+	else
+	  None in
+      let form = Newt.form vb None [] in
+      Newt.form_add_components form (List.map snd entries);
+      Newt.form_add_component form ok;
+
+      let selected =
+	let rec loop () =
+	  ignore (Newt.run_form form);
+	  let selected = List.filter_map (
+	    fun (handle, cb) ->
+	      if Newt.checkbox_get_value cb = '*' then Some handle else None
+	  ) entries in
+	  if force_one && selected = [] then loop ()
+	  else selected
+	in
+	loop () in
+
+      Newt.pop_window ();
+
+      selected
+  )
+
+(* Display a dialog with radio buttons, return the single selected item. *)
+let select_single ?stage width title items =
+  if items = [] then failwith "select_single: no items";
+
+  with_newt (
+    fun () ->
+      open_centered_window ?stage width 20 title;
+
+      let prev = ref None in
+      let entries =
+	List.mapi (
+	  fun i (label, handle) ->
+	    let rb = Newt.radio_button 1 (i+1) label (!prev = None) !prev in
+	    prev := Some rb;
+	    (handle, rb)
+	) items in
+
+      let ok = Newt.button (width-12) 16 "  OK  " in
+
+      let vb =
+	if List.length entries > 10 then
+	  Some (Newt.vertical_scrollbar 58 1 10
+		  Newt_int.NEWT_COLORSET_WINDOW
+		  Newt_int.NEWT_COLORSET_ACTCHECKBOX)
+	else
+	  None in
+      let form = Newt.form vb None [] in
+      Newt.form_add_components form (List.map snd entries);
+      Newt.form_add_component form ok;
+
+      let (selected, _) =
+	let rec loop () =
+	  ignore (Newt.run_form form);
+	  let r = Option.get !prev in
+	  let r = Newt.radio_get_current r in
+	  (* Now we compare 'r' to all the 'rb's in the list
+	   * to see which one is selected.
+	   *)
+	  try
+	    List.find (fun (_, rb) -> Newt.component_equals r rb) entries
+	  with
+	    Not_found -> loop ()
+	in
+	loop () in
+
+      Newt.pop_window ();
+
+      selected
+  )
+
 (* Shell-safe quoting function.  In fact there's one in stdlib so use it. *)
 let quote = Filename.quote
 
@@ -404,6 +504,7 @@ let auto_network () =
 
   (* NB. Lazy unmount is required because dhclient keeps its current
    * directory open on /etc/sysconfig/network-scripts/
+   * (Fixed in dhcp >= 4.0.0 but be generous anyway).
    *)
   sh "mount -o bind /mnt/root/etc /etc";
   let status = shwithstatus "/etc/init.d/network start" in
@@ -480,9 +581,17 @@ let ssh_disconnect (_, chan) =
   | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
   | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
 
+(* Use these functions to upload a file. *)
+let ssh_start_upload config filename =
+  let cmd =
+    sprintf "cat \\> %s/%s" (quote config.ssh_directory) (quote filename) in
+  ssh_connect config cmd
+
+let ssh_finish_upload = ssh_disconnect
+
 (* Test SSH connection. *)
 let test_ssh config =
-  printf "Testing SSH connection.\n\n%!";
+  printf "Testing SSH connection by listing files in remote directory ...\n\n%!";
 
   let cmd = sprintf "/bin/ls %s" (quote config.ssh_directory) in
   let conn = ssh_connect config cmd in
@@ -499,7 +608,7 @@ let test_ssh config =
     true
 
 (* Rewrite /mnt/root/etc/fstab. *)
-let rewrite_fstab state devices_to_send =
+let rewrite_fstab devices_to_send =
   let filename = "/mnt/root/etc/fstab" in
   if is_file filename = Some true then (
     sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
@@ -829,10 +938,32 @@ let rec main ttyname =
 
   (* Autodetect system memory. *)
   let system_memory =
-    let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
-    match mem with
-    | Some (mem::_) -> int_of_float (float_of_string mem)
-    | _ -> 256 in
+    (* Try to parse dmesg first to find the 'Memory:' report when
+     * the kernel booted.  If available, this can give us an
+     * indication of usable RAM on this system.
+     *)
+    let dmesg = shget "dmesg" in
+    try
+      let dmesg =
+	match dmesg with Some lines -> lines | None -> raise Not_found in
+      let line =
+	List.find (fun line -> String.starts_with line "Memory: ") dmesg in
+      let subs = Pcre.exec ~pat:"k/([[:digit:]]+)k available" line in
+      let mem = Pcre.get_substring subs 1 in
+      int_of_string mem / 1024
+    with
+      Not_found | Failure "int_of_string" ->
+	(* 'dmesg' can't be parsed.  The backup plan is to look
+	 * at /proc/meminfo.
+	 *)
+	let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
+	match mem with
+	| Some (mem::_) -> int_of_float (float_of_string mem)
+
+	(* For some reason even /proc/meminfo didn't work.  Just
+	 * assume 256 MB instead.
+	 *)
+	| _ -> 256 in
 
   (* Autodetect system # pCPUs. *)
   let system_nr_cpus =
@@ -857,34 +988,14 @@ let rec main ttyname =
 	  match !config_transfer_type with
 	  | Some t -> t
 	  | None ->
-	      open_centered_window ~stage:"Transfer type"
-		40 10 "Transfer type";
-
-	      let p2v =
-		Newt.radio_button 1 1 "Physical to virtual (P2V)" true
-		  None in
-	      let v2v =
-		Newt.radio_button 1 2 "Virtual to virtual (V2V)" false
-		  (Some p2v) in
-	      let ok = Newt.button 28 6 "  OK  " in
-
-	      let form = Newt.form None None [] in
-	      Newt.form_add_components form [p2v; v2v; ok];
+	      let items = [
+		"Physical to Virtual (P2V)", P2V;
+		"Virtual to Virtual (V2V)", V2V;
+	      ] in
 
-	      let t =
-		let rec loop () =
-		  ignore (Newt.run_form form);
-
-		  let r = Newt.radio_get_current p2v in
-		  if Newt.component_equals r p2v then P2V
-		  else if Newt.component_equals r v2v then V2V
-		  else loop ()
-		in
-		loop () in
-
-	      Newt.pop_window ();
-
-	      t in
+	      select_single ~stage:"Transfer type" 40
+		"Transfer type"
+		items in
 
 	(* Network configuration. *)
 	let config_network =
@@ -901,8 +1012,6 @@ let rec main ttyname =
 	       * root partitions found which allow us to do
 	       * automatic configuration in a known way.
 	       *)
-	      let partition_map = Hashtbl.create 13 in
-	      let maplen = ref 1 in
 	      let rec loop = function
 		| [] -> ()
 		| (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
@@ -911,11 +1020,7 @@ let rec main ttyname =
 		      sprintf "%s (%s)"
 			(dev_of_partition partition)
 			(string_of_linux_distro distro) in
-		    Hashtbl.add partition_map (!maplen) partition;
-		    ignore (
-		      Newt.listbox_append_entry autolist label (!maplen)
-		    );
-		    incr maplen;
+		    ignore (Newt.listbox_append_entry autolist label partition);
 		    loop parts
 		| _ :: parts -> loop parts
 	      in
@@ -924,7 +1029,7 @@ let rec main ttyname =
 	      (* If there is no suitable root partition (the listbox
 	       * is empty) then disable the auto option and the listbox.
 	       *)
-	      let no_auto = Hashtbl.length partition_map = 0 in
+	      let no_auto = Newt.listbox_item_count autolist = 0 in
 
 	      let auto =
 		Newt.radio_button 1 1
@@ -935,7 +1040,8 @@ let rec main ttyname =
 
 	      if no_auto then (
 		Newt.component_takes_focus auto false;
-		Newt.component_takes_focus autolist false
+		Newt.component_takes_focus
+		  (Newt.component_of_listbox autolist) false
 	      );
 
 	      let qemu =
@@ -977,10 +1083,12 @@ let rec main ttyname =
 	      in
 
 	      let enable_autolist () =
-		Newt.component_takes_focus autolist true
+		Newt.component_takes_focus
+		  (Newt.component_of_listbox autolist) true
 	      in
 	      let disable_autolist () =
-		Newt.component_takes_focus autolist false
+		Newt.component_takes_focus
+		  (Newt.component_of_listbox autolist) false
 	      in
 
 	      disable_static ();
@@ -998,7 +1106,8 @@ let rec main ttyname =
 	      let ok = Newt.button 48 16 "  OK  " in
 
 	      let form = Newt.form None None [] in
-	      Newt.form_add_components form [auto; autolist;
+	      Newt.form_add_components form [auto;
+					     Newt.component_of_listbox autolist;
 					     shell;qemu;nonet;static;
 					     label1;label2;label3;label4;label5;
 					     entry1;entry2;entry3;entry4;entry5;
@@ -1012,7 +1121,7 @@ let rec main ttyname =
 		  if Newt.component_equals r auto then (
 		    match Newt.listbox_get_current autolist with
 		    | None -> loop ()
-		    | Some i -> Auto (Hashtbl.find partition_map i)
+		    | Some part -> Auto part
 		  )
 		  else if Newt.component_equals r shell then Shell
 		  else if Newt.component_equals r qemu then QEMUUserNet
@@ -1150,260 +1259,172 @@ let rec main ttyname =
     if not (test_ssh config_ssh) then
       failwith "SSH configuration failed";
 
-(*
-
-  let ask_devices state =
-    let selected_devices = Option.default [] state.devices_to_send in
-    let devices = List.map (
-      fun (dev, blksize) ->
-	(dev,
-	 sprintf "/dev/%s (%.3f GB)" dev
-	   ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
-	 List.mem dev selected_devices)
-    ) all_block_devices in
-    match
-    checklist "Devices" "Pick devices to send" 15 50 8 devices
-    with
-    | Yes [] | No | Help | Error -> Ask_again
-    | Yes devices -> Next { state with devices_to_send = Some devices }
-    | Back -> Prev
-  in
-
-  let ask_root state =
-    let parts = List.mapi (
-      fun i (part, nature) ->
-	let descr =
-	  match nature with
-	  | LinuxSwap -> " (Linux swap)"
-	  | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
-	  | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
-	  | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
-	  | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
-	  | WindowsRoot -> " (Windows C:)"
-	  | LinuxBoot -> " (Linux /boot)"
-	  | NotRoot -> " (filesystem)"
-	  | UnknownNature -> "" in
-	(string_of_int i,
-	 dev_of_partition part ^ descr,
-	 Some part = state.root_filesystem)
-    ) all_partitions in
-    match
-    radiolist "Root device"
-      "Pick partition containing the root (/) filesystem" 18 70 9
-      parts
-    with
-    | Yes (i::_) ->
-	let (part, _) = List.nth all_partitions (int_of_string i) in
-	Next { state with root_filesystem = Some part }
-    | Yes [] | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+  (* Devices and root partition and target configuration selection stage. *)
+  let config_devices_to_send, config_root_filesystem, config_target =
+    with_newt (
+      fun () ->
+	let config_devices_to_send =
+	  match !config_devices_to_send with
+	  | Some ds -> ds
+	  | None ->
+	      let items = List.map (
+		  fun (dev, size) ->
+		    let label =
+		      sprintf "/dev/%s (%.3f GB)" dev
+		      ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in
+		    (label, dev, true)
+	      ) all_block_devices in
+
+	      select_multiple ~stage:"Block devices" ~force_one:true 60
+		"Select block devices to send"
+		items in
+
+	let config_root_filesystem =
+	  match !config_root_filesystem with
+	  | Some fs -> fs
+	  | None ->
+	      let items = List.map (
+		fun (part, nature) ->
+		  let label =
+		    sprintf "%s %s" (dev_of_partition part)
+		      (string_of_nature nature) in
+		  (label, part)
+	      ) all_partitions in
+
+	      select_single ~stage:"Root filesystem" 60
+		"Select root filesystem"
+		items in
+
+	let config_target =
+	  match !config_target with
+	  | Some t -> t
+	  | None ->
+	      open_centered_window ~stage:"Target system" 40 20
+		"Configure target system";
+
+	      let hvlabel = Newt.label 1 1 "Hypervisor:" in
+	      let hvlistbox = Newt.listbox 16 1 4 [Newt.SCROLL] in
+	      Newt.listbox_append_entry hvlistbox "Xen" (Some Xen);
+	      Newt.listbox_append_entry hvlistbox "QEMU" (Some QEMU);
+	      Newt.listbox_append_entry hvlistbox "KVM" (Some KVM);
+	      Newt.listbox_append_entry hvlistbox "Other" None;
+
+	      let archlabel = Newt.label 1 5 "Architecture:" in
+	      let archlistbox = Newt.listbox 16 5 4 [Newt.SCROLL] in
+	      Newt.listbox_append_entry archlistbox "i386" I386;
+	      Newt.listbox_append_entry archlistbox
+		    "x86-64 (64-bit x86)" X86_64;
+	      Newt.listbox_append_entry archlistbox "IA64 (Itanium)" IA64;
+	      Newt.listbox_append_entry archlistbox "PowerPC 32-bit" PPC;
+	      Newt.listbox_append_entry archlistbox "PowerPC 64-bit" PPC64;
+	      Newt.listbox_append_entry archlistbox "SPARC 32-bit" SPARC;
+	      Newt.listbox_append_entry archlistbox "SPARC 64-bit" SPARC64;
+	      Newt.listbox_append_entry archlistbox "Unknown/other" UnknownArch;
+
+	      (* Get the architecture of the selected root filesystem.
+	       * If not known, default to UnknownArch.
+	       *)
+	      Newt.listbox_set_current_by_key archlistbox UnknownArch;
+	      (try
+		 match List.assoc config_root_filesystem all_partitions with
+		 | LinuxRoot (arch, _) ->
+		     Newt.listbox_set_current_by_key archlistbox arch
+		 | _ -> ()
+		with
+		  Not_found -> ());
 
-  let ask_hypervisor state =
-    match
-    radiolist "Hypervisor"
-      "Choose hypervisor / virtualization system"
-      11 50 4 [
-	"xen", "Xen", state.hypervisor = Some Xen;
-	"qemu", "QEMU", state.hypervisor = Some QEMU;
-	"kvm", "KVM", state.hypervisor = Some KVM;
-	"other", "Other", state.hypervisor = None
-      ]
-    with
-    | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
-    | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
-    | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
-    | Yes _ -> Next { state with hypervisor = None }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+	      let memlabel = Newt.label 1 9 "Memory (MB):" in
+	      let mementry = Newt.entry 16 9
+		(Some (string_of_int system_memory)) 8 [] in
+	      let cpulabel = Newt.label 1 10 "CPUs:" in
+	      let cpuentry = Newt.entry 16 10
+		(Some (string_of_int system_nr_cpus)) 4 [] in
+	      let maclabel = Newt.label 1 11 "MAC addr:" in
+	      let macentry = Newt.entry 16 11 None 20 [] in
+	      let maclabel2 = Newt.label 1 12 "(leave MAC blank for random)" in
 
-  let ask_architecture state =
-    match
-    radiolist "Architecture" "Machine architecture" 16 50 8 [
-      "i386", "i386 and up (32 bit)", state.architecture = Some I386;
-      "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
-      "ia64", "Itanium IA64", state.architecture = Some IA64;
-      "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
-      "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
-      "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
-      "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
-      "auto", "Auto-detect",
-        state.architecture = None || state.architecture = Some UnknownArch;
-    ]
-    with
-    | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
-    | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
-    | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
-    | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
-    | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
-    | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
-    | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
-    | Yes _ -> Next { state with architecture = Some UnknownArch }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+	      let libvirtd =
+		Newt.checkbox 12 14 "Use remote libvirtd" '*' None in
 
-  let ask_memory state =
-    match
-    inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
-      10 50
-      (Option.map_default string_of_int "" state.memory)
-    with
-    | Yes (""::_ | []) -> Next { state with memory = Some 0 }
-    | Yes (mem::_) ->
-	let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
-	if mem < 0 || (mem > 0 && mem < 64) then Ask_again
-	else Next { state with memory = Some mem }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+	      let ok = Newt.button 28 16 "  OK  " in
 
-  let ask_vcpus state =
-    match
-    inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
-      10 50
-      (Option.map_default string_of_int "" state.vcpus)
-    with
-    | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
-    | Yes (vcpus::_) ->
-	let vcpus =
-	  try int_of_string vcpus with Failure "int_of_string" -> -1 in
-	if vcpus < 0 then Ask_again
-	else Next { state with vcpus = Some vcpus }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+	      let form = Newt.form None None [] in
+	      Newt.form_add_components form
+		[hvlabel; Newt.component_of_listbox hvlistbox;
+		 archlabel; Newt.component_of_listbox archlistbox;
+		 memlabel; mementry;
+		 cpulabel; cpuentry;
+		 maclabel; macentry; maclabel2;
+		 libvirtd;
+		 ok];
+
+	      let c =
+		let rec loop () =
+		  ignore (Newt.run_form form);
+		  try
+		    let hv = Newt.listbox_get_current hvlistbox in
+		    let arch = Newt.listbox_get_current archlistbox in
+		    let mem = int_of_string (Newt.entry_get_value mementry) in
+		    let cpus = int_of_string (Newt.entry_get_value cpuentry) in
+		    let mac = Newt.entry_get_value macentry in
+		    let libvirtd = Newt.checkbox_get_value libvirtd = '*' in
+		    if hv <> None && arch <> None && mem >= 0 && cpus >= 0
+		    then
+		      { tgt_hypervisor = Option.get hv;
+			tgt_architecture = Option.get arch;
+			tgt_memory = mem; tgt_vcpus = cpus;
+			tgt_mac_address =
+			  if mac <> "" then mac else random_mac_address ();
+			tgt_libvirtd = libvirtd }
+		    else
+		      loop ()
+		  with
+		    Not_found | Failure "int_of_string" -> loop ()
+		in
+		loop () in
 
-  let ask_mac_address state =
-    match
-    inputbox "MAC address"
-      "Network MAC address. Leave blank to use a random address." 10 50
-      (Option.default "" state.mac_address)
-    with
-    | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
-    | Yes (mac :: _) -> Next { state with mac_address = Some mac }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+	      Newt.pop_window ();
 
-  let ask_compression state =
-    match
-    radiolist "Network compression" "Enable network compression" 10 50 2 [
-      "yes", "Yes, compress network traffic", state.compression <> Some false;
-      "no", "No, don't compress", state.compression = Some false
-    ]
-    with
-    | Yes ("no"::_) -> Next { state with compression = Some false }
-    | Yes _ -> Next { state with compression = Some true }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+	      c in
 
-  let ask_verify state =
-    match
-    yesno "Verify and proceed"
-      (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
-
-Host:port:    %s : %s
-Directory:    %s
-Network:      %s
-Send devices: %s
-Root (/) dev: %s
-Hypervisor:   %s
-Architecture: %s
-Memory:       %s
-VCPUs:        %s
-MAC address:  %s
-Compression:  %b"
-         (Option.default "" state.remote_host)
-         (Option.default "" state.remote_port)
-         (Option.default "" state.remote_directory)
-         (match state.network with
-	  | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
-	  | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net"
-	  | None -> "")
-         (String.concat "," (Option.default [] state.devices_to_send))
-         (Option.map_default dev_of_partition "" state.root_filesystem)
-         (match state.hypervisor with
-	  | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
-	  | None -> "Other / not set")
-         (match state.architecture with
-	  | Some UnknownArch -> "Auto-detect"
-	  | Some arch -> string_of_architecture arch | None -> "")
-         (match state.memory with
-	  | Some 0 -> "Same as physical"
-	  | Some mem -> string_of_int mem ^ " MB" | None -> "")
-         (match state.vcpus with
-	  | Some 0 -> "Same as physical"
-	  | Some vcpus -> string_of_int vcpus | None -> "")
-         (match state.mac_address with
-	  | Some "" -> "Random" | Some mac -> mac | None -> "")
-         (Option.default true state.compression)
-      )
-      21 50
-    with
-    | Yes _ -> Next state
-    | Back -> Prev
-    | No | Help | Error -> Ask_again
-  in
+	config_devices_to_send, config_root_filesystem, config_target
+    ) in
 
-  (* This is the list of dialogs, in order.  The user can go forwards or
-   * backwards through them.
-   *
-   * The second parameter in each tuple is true if we need to skip
-   * this dialog statically (info already supplied in 'defaults' above).
-   *
-   * The third parameter in each tuple is a function that tests whether
-   * this dialog should be skipped, given other parts of the current state.
+  (* Try to get the capabilities from the remote machine.  If we fail
+   * it doesn't matter too much.
    *)
-  let dlgs =
-    let dont_skip _ = false in
-    [|
-    ask_greeting,      not defaults.greeting,             dont_skip;
-    ask_hostname,      defaults.remote_host <> None,      dont_skip;
-    ask_port,          defaults.remote_port <> None,      dont_skip;
-    ask_directory,     defaults.remote_directory <> None, dont_skip;
-    ask_username,      defaults.remote_username <> None,  dont_skip;
-    ask_network,       defaults.network <> None,          dont_skip;
-    ask_static_network_config,
-      defaults.static_network_config <> None,
-      (function { network = Some Static } -> false | _ -> true);
-    ask_devices,       defaults.devices_to_send <> None,  dont_skip;
-    ask_root,          defaults.root_filesystem <> None,  dont_skip;
-    ask_hypervisor,    defaults.hypervisor <> None,       dont_skip;
-    ask_architecture,  defaults.architecture <> None,     dont_skip;
-    ask_memory,        defaults.memory <> None,           dont_skip;
-    ask_vcpus,         defaults.vcpus <> None,            dont_skip;
-    ask_mac_address,   defaults.mac_address <> None,      dont_skip;
-    ask_compression,   defaults.compression <> None,      dont_skip;
-    ask_verify,        not defaults.greeting,             dont_skip;
-  |] in
-
-  (* Loop through the dialogs until we reach the end. *)
-  let rec loop ?(back=false) posn state =
-    eprintf "dialog loop: posn = %d, back = %b\n%!" posn back;
-    if posn >= Array.length dlgs then state (* Finished all dialogs. *)
-    else if posn < 0 then loop 0 state
-    else (
-      let dlg, skip_static, skip_dynamic = dlgs.(posn) in
-      if skip_static || skip_dynamic state then
-	(* Skip this dialog. *)
-	loop ~back (if back then posn-1 else posn+1) state
-      else (
-	(* Run dialog. *)
-	match dlg state with
-	| Next new_state -> loop (posn+1) new_state (* Forwards. *)
-	| Ask_again -> loop posn state	(* Repeat the question. *)
-	| Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *)
-      )
-    )
-  in
-  let state = loop 0 defaults in
-
-  eprintf "finished dialog loop\n%!";
-
-  (* In test mode, exit here before we do bad things to the developer's
+  let capabilities =
+    try
+      if not config_target.tgt_libvirtd then raise Not_found;
+
+      let proto, path =
+	match config_target.tgt_hypervisor with
+	| Some Xen -> "xen", "/"
+	| Some (QEMU|KVM) -> "qemu", "/system"
+	| None -> raise Not_found in
+      let name =
+	sprintf "%s+ssh://%s@%s:%s%s"
+	  proto config_ssh.ssh_username
+	  config_ssh.ssh_host config_ssh.ssh_port path in
+      eprintf "fetch capabilities from %S\n%!" name;
+
+      let conn = Libvirt.Connect.connect_readonly ~name () in
+      let caps = Libvirt.Connect.get_capabilities conn in
+      Libvirt.Connect.close conn;
+
+      eprintf "capabilities:\n%s\n%!" caps;
+
+      Some caps
+    with
+    | Not_found -> None
+    | Libvirt.Virterror err ->
+	eprintf "libvirt error: %s\n%!" (Libvirt.Virterror.to_string err);
+	None
+    | Invalid_argument str ->
+	eprintf "libvirt error: %s\n%!" str;
+	None in
+
+  (* In test mode, exit here before we do Bad Things to the developer's
    * hard disk.
    *)
   if test_dialog_stages then exit 1;
@@ -1415,28 +1436,26 @@ Compression:  %b"
   sh "rm -f /etc/lvm.new/cache/.cache";
 
   (* Snapshot the block devices to send. *)
-  let devices_to_send = Option.get state.devices_to_send in
-  let devices_to_send =
+  let config_devices_to_send =
     List.map (
       fun origin_dev ->
 	let snapshot_dev = snapshot_name origin_dev in
 	snapshot origin_dev snapshot_dev;
 	(origin_dev, snapshot_dev)
-    ) devices_to_send in
+    ) config_devices_to_send in
 
   (* Run kpartx on the snapshots. *)
   List.iter (
     fun (origin, snapshot) ->
       shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
-  ) devices_to_send;
+  ) config_devices_to_send;
 
   (* Rescan for LVs. *)
   sh "vgscan";
   sh "vgchange -a y";
 
   (* Mount the root filesystem under /mnt/root. *)
-  let root_filesystem = Option.get state.root_filesystem in
-  (match root_filesystem with
+  (match config_root_filesystem with
    | Part (dev, partnum) ->
        let dev = dev ^ partnum in
        let snapshot_dev = snapshot_name dev in
@@ -1450,41 +1469,35 @@ Compression:  %b"
   );
 
   (* Work out what devices will be called at the remote end. *)
-  let devices_to_send = List.map (
+  let config_devices_to_send = List.map (
     fun (origin_dev, snapshot_dev) ->
       let remote_dev = remote_of_origin_dev origin_dev in
       (origin_dev, snapshot_dev, remote_dev)
-  ) devices_to_send in
+  ) config_devices_to_send in
 
   (* Modify files on the root filesystem. *)
-  rewrite_fstab state devices_to_send;
+  rewrite_fstab config_devices_to_send;
   (* XXX Other files to rewrite? *)
 
   (* Unmount the root filesystem and sync disks. *)
   sh "umount /mnt/root";
   sh "sync";				(* Ugh, should be in stdlib. *)
 
-  (* Get architecture of root filesystem, detected previously. *)
-  let system_architecture =
-    try
-      (match List.assoc root_filesystem all_partitions with
-       | LinuxRoot (arch, _) -> arch
-       | _ -> raise Not_found
-      )
-    with
-      Not_found ->
-	(* None was detected before, so assume same as live CD. *)
+  (* If architecture is set to UnknownArch, then assume the same
+   * architecture as the live CD.
+   *)
+  let config_target =
+    match config_target.tgt_architecture with
+    | UnknownArch ->
 	let arch = shget "uname -m" in
-	match arch with
-	| Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
-	| Some ("x86_64"::_) -> X86_64
-	| Some ("ia64"::_) -> IA64
-	| _ -> I386 (* probably wrong XXX *) in
-
-  let remote_host = Option.get state.remote_host in
-  let remote_port = Option.get state.remote_port in
-  let remote_directory = Option.get state.remote_directory in
-  let remote_username = Option.get state.remote_username in
+	let arch =
+	  match arch with
+	  | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
+	  | Some ("x86_64"::_) -> X86_64
+	  | Some ("ia64"::_) -> IA64
+	  | _ -> I386 (* probably wrong XXX *) in
+	{ config_target with tgt_architecture = arch }
+    | _ -> config_target in
 
   (* XXX This is using the hostname derived from network configuration
    * above.  We might want to ask the user to choose.
@@ -1496,11 +1509,11 @@ Compression:  %b"
     "p2v-" ^ hostname ^ "-" ^ date in
 
   (* Work out what the image filenames will be at the remote end. *)
-  let devices_to_send = List.map (
+  let config_devices_to_send = List.map (
     fun (origin_dev, snapshot_dev, remote_dev) ->
       let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
       (origin_dev, snapshot_dev, remote_dev, remote_name)
-  ) devices_to_send in
+  ) config_devices_to_send in
 
   (* Write a configuration file.  Not sure if this is any better than
    * just 'sprintf-ing' bits of XML text together, but at least we will
@@ -1515,23 +1528,6 @@ Compression:  %b"
    *)
   let conf_filename = basename ^ ".conf" in
 
-  let architecture =
-    match state.architecture with
-    | Some UnknownArch | None -> system_architecture
-    | Some arch -> arch in
-  let memory =
-    match state.memory with
-    | Some 0 | None -> system_memory
-    | Some memory -> memory in
-  let vcpus =
-    match state.vcpus with
-    | Some 0 | None -> system_nr_cpus
-    | Some n -> n in
-  let mac_address =
-    match state.mac_address with
-    | Some "" | None -> random_mac_address ()
-    | Some mac -> mac in
-
   let xml =
     (* Shortcut to make "<name>value</name>". *)
     let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
@@ -1541,15 +1537,17 @@ Compression:  %b"
     (* Standard stuff for every domain. *)
     let name = leaf "name" hostname in
     let uuid = leaf "uuid" (random_uuid ()) in
-    let maxmem = leaf "maxmem" (string_of_int (memory * 1024)) in
-    let memory = leaf "memory" (string_of_int (memory * 1024)) in
-    let vcpu = leaf "vcpu" (string_of_int vcpus) in
+    let maxmem, memory =
+      let m =
+	leaf "maxmem" (string_of_int (config_target.tgt_memory * 1024)) in
+      m, m in
+    let vcpu = leaf "vcpu" (string_of_int config_target.tgt_vcpus) in
 
     (* Top-level stuff which differs for each HV type (isn't this supposed
      * to be portable ...)
      *)
     let extras =
-      match state.hypervisor with
+      match config_target.tgt_hypervisor with
       | Some Xen ->
 	  [Xml.Element ("os", [],
 			[leaf "type" "hvm";
@@ -1567,7 +1565,8 @@ Compression:  %b"
 	  [Xml.Element ("os", [],
 			[Xml.Element ("type",
 				      ["arch",
-				       string_of_architecture architecture;
+				       string_of_architecture
+					 config_target.tgt_architecture;
 				       "machine","pc"],
 				      [Xml.PCData "hvm"]);
 			 tleaf "boot" ["dev", "hd"]])]
@@ -1577,7 +1576,7 @@ Compression:  %b"
     (* <devices> section. *)
     let devices =
       let emulator =
-	match state.hypervisor with
+	match config_target.tgt_hypervisor with
 	| Some Xen ->
 	    [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
 	| Some QEMU ->
@@ -1588,7 +1587,8 @@ Compression:  %b"
 	    [] in
       let interface =
 	Xml.Element ("interface", ["type", "user"],
-		     [tleaf "mac" ["address", mac_address]]) in
+		     [tleaf "mac" ["address",
+				   config_target.tgt_mac_address]]) in
       (* XXX should have an option for Xen bridging:
 	Xml.Element (
 	"interface", ["type","bridge"],
@@ -1602,10 +1602,11 @@ Compression:  %b"
 	  Xml.Element (
 	    "disk", ["type", "file";
 		     "device", "disk"],
-	    [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
+	    [tleaf "source" ["file",
+			     config_ssh.ssh_directory ^ "/" ^ remote_name];
 	     tleaf "target" ["dev", remote_dev]]
 	  )
-      ) devices_to_send in
+      ) config_devices_to_send in
 
       Xml.Element (
 	"devices", [],
@@ -1615,7 +1616,7 @@ Compression:  %b"
     (* Put it all together in <domain type='foo'>. *)
     Xml.Element (
       "domain",
-      (match state.hypervisor with
+      (match config_target.tgt_hypervisor with
        | Some Xen -> ["type", "xen"]
        | Some QEMU -> ["type", "qemu"]
        | Some KVM -> ["type", "kvm"]
@@ -1630,7 +1631,7 @@ Compression:  %b"
     let xml = Xml.to_string_fmt xml in
 
     let conn_arg =
-      match state.hypervisor with
+      match config_target.tgt_hypervisor with
       | Some Xen | None -> ""
       | Some QEMU | Some KVM -> " -c qemu:///system" in
     let xml = sprintf "\
@@ -1645,10 +1646,10 @@ Compression:  %b"
     let xml_len = String.length xml in
     eprintf "length of configuration file is %d bytes\n%!" xml_len;
 
-    let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
+    let (sock,_) as conn = ssh_start_upload config_ssh conf_filename in
     (* In OCaml this actually loops calling write(2) *)
     ignore (write sock xml 0 xml_len);
-    do_disconnect conn in
+    ssh_finish_upload conn in
 
   (* Send the device snapshots to the remote host. *)
   (* XXX This code should be made more robust against both network
@@ -1670,7 +1671,7 @@ Compression:  %b"
       let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
 
       (* Now connect. *)
-      let (sock,_) as conn = do_connect remote_name size in
+      let (sock,_) as conn = ssh_start_upload config_ssh remote_name in
 
       (* Copy the data. *)
       let spinners = "|/-\\" (* "Oo" *) in
@@ -1717,22 +1718,21 @@ Compression:  %b"
       printf "\n\n%!"; (* because of the messages printed above *)
 
       (* Disconnect. *)
-      do_disconnect conn
-  ) devices_to_send;
+      ssh_finish_upload conn
+  ) config_devices_to_send;
 
   (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
 
   (* Clean up and reboot. *)
   ignore (
-    msgbox (sprintf "%s completed" program_name)
+    message_box (sprintf "%s completed" program_name)
       (sprintf "\nThe physical to virtual migration is complete.\n\nPlease verify the disk image(s) and configuration file on the remote host, and then start up the virtual machine by doing:\n\ncd %s\nvirsh define %s\n\nWhen you press [OK] this machine will reboot."
-	 remote_directory conf_filename)
-      17 50
+	 config_ssh.ssh_directory conf_filename)
   );
 
   shfailok "eject";
   shfailok "reboot";
-*)
+
   exit 0
 
 (*----------------------------------------------------------------------*)