X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=virt-p2v;h=922ad40a0b4465f9d68feba21734fbb84c522c86;hb=a8f18a057ab1c91edcf689420c19ce54a65be315;hp=133cee1b9af51101a517f7cbc81946da8257d41b;hpb=7d4f5476b3a7e286e36c6bf6bf06727c56a3f58f;p=virt-p2v.git

diff --git a/virt-p2v b/virt-p2v
index 133cee1..922ad40 100755
--- a/virt-p2v
+++ b/virt-p2v
@@ -21,46 +21,47 @@
  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  *)
 
-#load "unix.cma";;
-#directory "+extlib";;
-#load "extLib.cma";;
-#directory "+pcre";;
-#load "pcre.cma";;
-#directory "+xml-light";;
-#load "xml-light.cma";;
-
-open Unix
-open Printf
-open ExtList
-open ExtString
-
-type state = { greeting : bool;
-	       remote_host : string option; remote_port : string option;
-	       remote_directory : string option;
-	       remote_username : string option;
-	       network : network option;
-	       static_network_config : static_network_config option;
-	       devices_to_send : string list option;
-	       root_filesystem : partition option;
-	       hypervisor : hypervisor option;
-	       architecture : architecture option;
-	       memory : int option; vcpus : int option;
-	       mac_address : string option;
-	     }
-and network = Auto
-	    | Shell
-	    | QEMUUserNet
-	    | Static
-and partition = Part of string * string (* eg. "hda", "1" *)
-              | LV of string * string	(* eg. "VolGroup00", "LogVol00" *)
-and hypervisor = Xen | QEMU | KVM
-and architecture = I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
-		 | OtherArch of string | UnknownArch
-and static_network_config = string * string * string * string * string
-    (* interface, address, netmask, gateway, nameserver *)
+type partition =
+  | Part of string * string		(* eg. "hda", "1" *)
+  | LV of string * string	        (* eg. "VolGroup00", "LogVol00" *)
+type transfer =
+  | P2V					(* physical to virtual *)
+  | V2V					(* virtual to virtual *)
+  (*| V2P*)                             (* virtual to physical - not impl *)
+type network =
+  | Auto of partition			(* Automatic network configuration. *)
+  | Shell				(* Start a shell. *)
+  | QEMUUserNet				(* Assume we're running under qemu. *)
+  | Static of string * string * string * string * string
+      (* interface, address, netmask, gateway, nameserver *)
+  | NoNetwork
+type ssh_config = {
+  ssh_host : string;			(* Remote host for SSH. *)
+  ssh_port : string;			(* Remote port. *)
+  ssh_directory : string;		(* Remote directory. *)
+  ssh_username : string;		(* Remote username. *)
+  ssh_compression : bool;		(* If true, use SSH compression. *)
+  ssh_check : bool;			(* If true, check SSH is working. *)
+}
+type hypervisor =
+  | Xen
+  | QEMU
+  | KVM
+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.
+(* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section.
  *
  * If left as they are, then this will create a generic virt-p2v script
  * which asks the user for each question.  If you set the defaults here
@@ -69,34 +70,62 @@ and static_network_config = string * string * string * string * string
  *
  * Note that 'None' means 'no default' (ie. ask the user) whereas
  * 'Some foo' means use 'foo' as the answer.
+ *
+ * These are documented in the virt-p2v(1) manual page.
+ *
+ * After changing them, run './virt-p2v --test' to check syntax.
  *)
-let defaults = {
-  (* If greeting is true, wait for keypress after boot and during
-   * final verification.  Set to 'false' for less interactions.
-   *)
-  greeting = true;
 
-  (* These are now documented in the man page virt-p2v(1).
-   * 'None' means ask the user.
-   * After changing them, run './virt-p2v --test' to check syntax.
-   *)
-  remote_host = None;
-  remote_port = None;
-  remote_directory = None;
-  remote_username = None;
-  devices_to_send = None;
-  root_filesystem = None;
-  network = None;
-  static_network_config = None;
-  hypervisor = None;
-  architecture = None;
-  memory = None;
-  vcpus = None;
-  mac_address = None;
-}
+(* If greeting is true, wait for keypress after boot and during
+ * final verification.  Set to 'false' for less interactions.
+ *)
+let config_greeting = ref true
+
+(* General type of transfer. *)
+let config_transfer_type = ref None
+
+(* Network configuration. *)
+let config_network = ref None
+
+(* SSH configuration. *)
+let config_ssh = ref None
+
+(* What to transfer. *)
+let config_devices_to_send = ref None
+let config_root_filesystem = ref None
+
+(* Configuration of the target. *)
+let config_target = ref None
+
+(* The name of the program as displayed in various places. *)
+let program_name = "virt-p2v"
+
+(* If you want to test the dialog stages, set this to true. *)
+let test_dialog_stages = false
+
 (* END OF CUSTOM virt-p2v SCRIPT SECTION.                               *)
 (*----------------------------------------------------------------------*)
 
+(* Load external libraries. *)
+;;
+#load "unix.cma";;
+#directory "+extlib";;
+#load "extLib.cma";;
+#directory "+pcre";;
+#load "pcre.cma";;
+#directory "+newt";;
+#load "mlnewt.cma";;
+#directory "+xml-light";;
+#load "xml-light.cma";;
+#directory "+libvirt";;
+#load "mllibvirt.cma";;
+
+open Unix
+open Printf
+open ExtList
+open ExtString
+
+(*----------------------------------------------------------------------*)
 (* General helper functions. *)
 
 let sort_uniq ?(cmp = compare) xs =	(* sort and uniq a list *)
@@ -130,10 +159,6 @@ let string_of_architecture = function
   | OtherArch arch -> arch
   | UnknownArch -> ""
 
-type dialog_status = Yes of string list | No | Help | Back | Error
-
-type ask_result = Next of state | Prev | Ask_again
-
 type nature = LinuxSwap
 	    | LinuxRoot of architecture * linux_distro
 	    | WindowsRoot		(* Windows C: *)
@@ -159,134 +184,161 @@ and string_of_linux_distro = function
   | Debian (a,b) -> sprintf "Debian %d.%d" a b
   | OtherLinux -> "Linux"
 
-(* Dialog functions.
- *
- * Each function takes some common parameters (eg. ~title) and some
- * dialog-specific parameters.
+type ('a, 'b) either = Either of 'a | Or of 'b
+
+(* We go into and out of newt mode at various stages, but we might
+ * also need to put up a message at any time.  This keeps track of
+ * whether we are in newt mode or not.
  *
- * Returns the exit status (Yes lines | No | Help | Back | Error).
+ * General tip: Try to do any complex operations like setting up the
+ * network or probing disks outside newt mode, and try not to throw
+ * exceptions in newt mode.
  *)
-let msgbox, yesno, inputbox, radiolist, checklist, form =
-  (* Internal function to actually run the "dialog" shell command. *)
-  let run_dialog cparams params =
-    let params = cparams @ params in
-    eprintf "dialog %s\n%!"
-      (String.concat " " (List.map (sprintf "%S") params));
-
-    (* 'dialog' writes its output/result to stderr, so we need to take
-     * special steps to capture that - in other words, manual pipe/fork.
-     *)
-    let rfd, wfd = pipe () in
-    match fork () with
-    | 0 ->				(* child, runs dialog *)
-	close rfd;
-	dup2 wfd stderr;		(* capture stderr to pipe *)
-	execvp "dialog" (Array.of_list ("dialog" :: params))
-    | pid ->				(* parent *)
-	close wfd;
-	let chan = in_channel_of_descr rfd in
-	let result = input_all_lines chan in
-	close rfd;
-	eprintf "dialog result: %S\n%!" (String.concat "\n" result);
-	match snd (wait ()) with
-	| WEXITED 0 -> Yes result       (* something selected / entered *)
-	| WEXITED 1 -> No		(* cancel / no button *)
-	| WEXITED 2 -> Help		(* help pressed *)
-	| WEXITED 3 -> Back		(* back button *)
-	| WEXITED _ -> Error		(* error or Esc *)
-	| WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
-	| WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
-  in
+let in_newt = ref false
+let with_newt f =
+  if !in_newt then f ()
+  else (
+    in_newt := true;
+    let r =
+      try Either (Newt.init_and_finish f)
+      with exn -> Or exn in
+    in_newt := false;
+    match r with Either r -> r | Or exn -> raise exn
+  )
 
-  (* Handle the common parameters.  Note Continuation Passing Style. *)
-  let with_common cont ?(cancel=false) ?(backbutton=true) title =
-    let params = ["--title"; title] in
-    let params = if not cancel then "--nocancel" :: params else params in
-    let params =
-      if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
-      else params in
-    cont params
-  in
+(* Clear the screen, open a new centered window, make sure the background
+ * and help messages are consistent.
+ *)
+let open_centered_window ?stage width height title =
+  if not !in_newt then failwith "open_centered_window: not in newt mode";
+  Newt.cls ();
+  Newt.centered_window width height title;
+  let root_text =
+    program_name ^ (match stage with
+		    | None -> ""
+		    | Some stage -> " - " ^ stage) in
+  Newt.draw_root_text 0 0 root_text;
+  Newt.push_help_line "F12 for next screen | [ALT] [F2] root / no password for shell"
+
+(* Some general dialog boxes. *)
+let message_box title text =
+  with_newt (
+    fun () ->
+      open_centered_window 40 20 title;
+
+      let textbox = Newt.textbox 1 1 36 14 [Newt.WRAP; Newt.SCROLL] in
+      Newt.textbox_set_text textbox text;
+      let ok = Newt.button 28 16 "  OK  " in
+      let form = Newt.form None None [] in
+      Newt.form_add_components form [textbox; ok];
+
+      Newt.component_takes_focus ok true;
+
+      ignore (Newt.run_form form);
+      Newt.pop_window ()
+  )
 
-  (* Message box and yes/no box. *)
-  let rec msgbox =
-    with_common (
-      fun cparams text height width ->
-	run_dialog cparams
-	  [ "--msgbox"; text; string_of_int height; string_of_int width ]
-    )
-  and yesno =
-    with_common (
-      fun cparams text height width ->
-	run_dialog cparams
-	  [ "--yesno"; text; string_of_int height; string_of_int width ]
-    )
-
-  (* Simple input box. *)
-  and inputbox =
-    with_common (
-      fun cparams text height width default ->
-	run_dialog cparams
-	  [ "--inputbox"; text; string_of_int height; string_of_int width;
-	    default ]
-    )
-
-  (* Radio list and check list. *)
-  and radiolist =
-    with_common (
-      fun cparams text height width listheight items ->
-	let items = List.map (
-	  function
-	  | tag, item, true -> [ tag; item; "on" ]
-	  | tag, item, false -> [ tag; item; "off" ]
-	) items in
-	let items = List.concat items in
-	let items = "--single-quoted" ::
-	  "--radiolist" :: text ::
-	  string_of_int height :: string_of_int width ::
-	  string_of_int listheight :: items in
-	run_dialog cparams items
-    )
-  and checklist =
-    with_common (
-      fun cparams text height width listheight items ->
-	let items = List.map (
-	  function
-	  | tag, item, true -> [ tag; item; "on" ]
-	  | tag, item, false -> [ tag; item; "off" ]
+(* Fail and exit with error. *)
+let failwith text =
+  prerr_endline text;
+  let text = "\n" ^ text ^ "\n\nIf you want to report this error, there is a shell on [ALT] [F2], log in as root with no password.\n\nPlease provide the contents of /tmp/virt-p2v.log and output of the 'dmesg' command." in
+  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 items = List.concat items in
-	let items = "--separate-output" ::
-	  "--checklist" :: text ::
-	  string_of_int height :: string_of_int width ::
-	  string_of_int listheight :: items in
-	run_dialog cparams items
-    )
-
-  (* Form. *)
-  and form =
-    with_common (
-      fun cparams text height width formheight items ->
-	let items = List.map (
-	  fun (label, y, x, item, y', x', flen, ilen) ->
-	    [ label; string_of_int y; string_of_int x; item;
-	      string_of_int y'; string_of_int x';
-	      string_of_int flen; string_of_int ilen ]
+
+      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 items = List.concat items in
-	let items = "--form" :: text ::
-	  string_of_int height :: string_of_int width ::
-	  string_of_int formheight :: items in
-	run_dialog cparams items
-    )
-  in
-  msgbox, yesno, inputbox, radiolist, checklist, form
 
-(* Print failure dialog and exit. *)
-let fail_dialog text =
-  let text = "\n" ^ text ^ "\n\nIf you want to report this error, there is a shell on [ALT] [F2], log in as root with no password.\n\nPlease provide the contents of /tmp/virt-p2v.log and output of the 'dmesg' command." in
-  ignore (msgbox "Error" text 17 50);
-  exit 1
+      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
@@ -294,7 +346,7 @@ let quote = Filename.quote
 (* Run a shell command and check it returns 0. *)
 let sh cmd =
   eprintf "sh: %s\n%!" cmd;
-  if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
+  if Sys.command cmd <> 0 then failwith (sprintf "Command failed:\n\n%s" cmd)
 
 let shfailok cmd =
   eprintf "shfailok: %s\n%!" cmd;
@@ -339,8 +391,8 @@ let is_file path =
   try Some ((stat path).st_kind = S_REG)
   with Unix_error (ENOENT, "stat", _) -> None
 
-(* Useful regular expression. *)
-let whitespace = Pcre.regexp "[ \t]+"
+(*----------------------------------------------------------------------*)
+(* P2V-specific helper functions. *)
 
 (* Generate a predictable safe name containing only letters, numbers
  * and underscores.  If passed a string with no letters or numbers,
@@ -368,13 +420,13 @@ type block_device = string * int64	(* "hda" & size in bytes *)
 let get_lvs =
   let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
 
-  function () ->
+  fun () ->
     match
     shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
     with
     | None -> []
     | Some lines ->
-	let lines = List.map (Pcre.split ~rex:whitespace) lines in
+	let lines = List.map Pcre.split lines in
 	List.map (
 	  function
 	  | [vg; lv; pvs; lvsize]
@@ -434,7 +486,7 @@ let snapshot =
       match lines with
       | Some (sectors::_) -> Int64.of_string sectors
       | Some [] | None ->
-	  fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
+	  failwith (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
 
     (* Create the snapshot origin device.  Called, eg. snap_sda1_org *)
     sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
@@ -446,48 +498,22 @@ let snapshot =
 (* Try to perform automatic network configuration, assuming a Fedora or
  * RHEL-like root filesystem mounted on /mnt/root.
  *)
-let auto_network state =
+let auto_network () =
   (* Fedora gives an error if this file doesn't exist. *)
   sh "touch /etc/resolv.conf";
 
-(*
-  (* We can run /mnt/root/etc/init.d/network in a chroot environment,
-   * however this won't work directly because the architecture of the
-   * binaries under /mnt/root (eg. /mnt/root/sbin/ip) might not match
-   * the architecture of the live CD kernel.  In particular, a 32 bit
-   * live CD cannot run 64 bit binaries.  So we also have to bind-mount
-   * the live CD's /bin, /sbin, /lib etc. over the equivalents in
-   * /mnt/root.
-   *)
-  let bind dir =
-    if is_dir dir = Some true then
-      sh ("mount -o bind " ^ quote dir ^ " " ^ quote ("/mnt/root" ^ dir))
-  in
-  let unbind dir =
-    if is_dir dir = Some true then sh ("umount -l " ^ quote ("/mnt/root" ^ dir))
-  in
-  let dirs = [
-    "/bin"; "/sbin"; "/lib"; "/lib64";
-    "/usr/bin"; "/usr/sbin"; "/usr/lib"; "/usr/lib64";
-    "/proc"; "/sys"
-  ] in
-  List.iter bind dirs;
-  let status = shwithstatus "chroot /mnt/root /etc/init.d/network start" in
-  List.iter unbind dirs;
-*)
-
-  (* Simpler way to do the above.
-   * NB. Lazy unmount is required because dhclient keeps its current
+  (* 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
   sh "umount -l /etc";
 
-  (* Try to ping the remote host to see if this worked. *)
-  shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
+  (* Try to ping the default gateway to see if this worked. *)
+  shfailok "ping -c3 `/sbin/ip route list match 0.0.0.0 | head -1 | awk '{print $3}'`";
 
-  if state.greeting then (
+  if !config_greeting then (
     printf "\n\nDid automatic network configuration work?\n";
     printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
     printf "    (y/n) %!";
@@ -499,23 +525,21 @@ let auto_network state =
     status = 0
 
 (* Configure the network statically. *)
-let static_network state =
-  match state.static_network_config with
-  | None -> false			(* failed *)
-  | Some (interface, address, netmask, gateway, nameserver) ->
-      let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
-      try
-	do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
-			  (quote interface) (quote address) (quote netmask));
-	do_cmd_or_exit (sprintf "route add default gw %s %s"
-			  (quote gateway) (quote interface));
-	if nameserver <> "" then
-	  do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
-			    (quote nameserver));
-	true				(* succeeded *)
-      with
-	Exit -> false			(* failed *)
+let static_network (interface, address, netmask, gateway, nameserver) =
+  let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
+  try
+    do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
+		      (quote interface) (quote address) (quote netmask));
+    do_cmd_or_exit (sprintf "route add default gw %s %s"
+		      (quote gateway) (quote interface));
+    if nameserver <> "" then
+      do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
+			(quote nameserver));
+    true				(* succeeded *)
+  with
+    Exit -> false			(* failed *)
 
+(* http://fabrice.bellard.free.fr/qemu/qemu-doc.html#SEC30 *)
 let qemu_network () =
   sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0";
   sh "route add default gw 10.0.2.2 eth0";
@@ -531,8 +555,60 @@ let remote_of_origin_dev =
   fun dev ->
     Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
 
+(* Make an SSH connection to the remote machine, execute command.
+ * The connection remains open until you call ssh_disconnect, it
+ * times out or there is some error.
+ *
+ * NB. The command is NOT quoted.
+ *
+ * Returns a pair (file descriptor, channel), both referring to the
+ * same thing.  Use whichever is more convenient.
+ *)
+let ssh_connect config cmd =
+  let cmd = sprintf "ssh%s -l %s -p %s %s %s"
+    (if config.ssh_compression then " -C" else "")
+    (quote config.ssh_username) (quote config.ssh_port) (quote config.ssh_host)
+    cmd in
+  eprintf "ssh_connect: %s\n%!" cmd;
+  let chan = open_process_out cmd in
+  descr_of_out_channel chan, chan
+
+let ssh_disconnect (_, chan) =
+  eprintf "ssh_disconnect\n%!";
+  match close_process_out chan with
+  | WEXITED 0 -> ()		(* OK *)
+  | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
+  | 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 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
+  ssh_disconnect conn;
+
+  if !config_greeting then (
+    printf "\n\nDid SSH work?\n";
+    printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
+    printf "    (y/n) %!";
+    let line = read_line () in
+    String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
+  )
+  else
+    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"));
@@ -540,7 +616,7 @@ let rewrite_fstab state devices_to_send =
     let chan = open_in filename in
     let lines = input_all_lines chan in
     close_in chan;
-    let lines = List.map (Pcre.split ~rex:whitespace) lines in
+    let lines = List.map Pcre.split lines in
     let lines = List.map (
       function
       | dev :: rest when String.starts_with dev "/dev/" ->
@@ -558,13 +634,13 @@ let rewrite_fstab state devices_to_send =
 	  fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
 	    dev mountpoint fstype options freq passno
       | line ->
-	  output_string chan (String.concat " " line)
+	  output_string chan (String.concat " " line);
+	  output_char chan '\n'
     ) lines;
     close_out chan
   )
 
-let () = Random.self_init ()
-
+(* Generate a random MAC address in the Xen-reserved space. *)
 let random_mac_address () =
   let random =
     List.map (sprintf "%02x") (
@@ -572,6 +648,7 @@ let random_mac_address () =
     ) in
   String.concat ":" ("00"::"16"::"3e"::random)
 
+(* Generate a random UUID. *)
 let random_uuid =
   let hex = "0123456789abcdef" in
   fun () ->
@@ -579,8 +656,45 @@ let random_uuid =
   for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
   str
 
+(*----------------------------------------------------------------------*)
 (* Main entry point. *)
+
+(* The general plan for the main function is to operate in stages:
+ *
+ *      Start-up
+ *         |
+ *         V
+ *      Information gathering about the system
+ *         |     (eg. block devices, number of CPUs, etc.)
+ *         V
+ *      Greeting and type of transfer question
+ *         |
+ *         V
+ *      Set up the network
+ *         |     (after this point we have a working network)
+ *         V
+ *      Set up SSH
+ *         |     (after this point we have a working SSH connection)
+ *         V
+ *      Questions about what to transfer (block devs, root fs) <--.
+ *         |                                                      |
+ *         V                                                      |
+ *      Questions about hypervisor configuration                  |
+ *         |                                                      |
+ *         V                                                      |
+ *      Verify information -------- user wants to change info ----/
+ *         |
+ *         V
+ *      Perform transfer
+ *
+ * Prior versions of virt-p2v (the ones which used 'dialog') had support
+ * for a back button so they could go back through dialogs.  I removed
+ * this because it was hard to support and not particularly useful.
+ *)
+
 let rec main ttyname =
+  Random.self_init ();
+
   (* Running from an init script.  We don't have much of a
    * login environment, so set one up.
    *)
@@ -602,7 +716,8 @@ let rec main ttyname =
   (* Log the start up time. *)
   eprintf "\n\n**************************************************\n\n";
   let tm = localtime (time ()) in
-  eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
+  eprintf "%s starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
+    program_name
     (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
 
   (* Connect stdin/stdout to the tty. *)
@@ -613,17 +728,18 @@ let rec main ttyname =
        dup2 fd stdin;
        dup2 fd stdout;
        close fd);
-  printf "virt-p2v starting up ...\n%!";
+  printf "%s starting up ...\n%!" program_name;
 
   (* Disable screen blanking on tty. *)
   sh "setterm -blank 0";
 
   (* Check that the environment is a sane-looking live CD.  If not, bail. *)
-  if is_dir "/mnt/root" <> Some true then
-    fail_dialog
+  if not test_dialog_stages && is_dir "/mnt/root" <> Some true then
+    failwith
       "You should only run this script from the live CD or a USB key.";
 
-  printf "virt-p2v detecting hard drives (this may take some time) ...\n%!";
+  (* Start of the information gathering phase. *)
+  printf "Detecting hard drives (this may take some time) ...\n%!";
 
   (* Search for all non-removable block devices.  Do this early and bail
    * if we can't find anything.  This is a list of strings, like "hda".
@@ -650,7 +766,7 @@ let rec main ttyname =
       (String.concat "; "
 	 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
     if devices = [] then
-      fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
+      failwith "No non-removable block devices (hard disks, etc.) could be found on this machine.";
     devices in
 
   (* Search for partitions and LVs (anything that could contain a
@@ -818,337 +934,500 @@ let rec main ttyname =
     ) all_partitions
   in
 
-  printf "virt-p2v finished detecting hard drives\n%!";
-
-  (* Dialogs. *)
-  let ask_greeting state =
-    ignore (msgbox "virt-p2v" "\nWelcome to virt-p2v, a live CD for migrating a physical machine to a virtualized host.\n\nTo continue press the Return key.\n\nTo get a shell you can use [ALT] [F2] and log in as root with no password.\n\nExtra information is logged in /tmp/virt-p2v.log but this file disappears when the machine reboots." 18 50);
-    Next state
-  in
+  printf "Finished detecting hard drives.\n%!";
 
-  let ask_hostname state =
-    match
-    inputbox "Remote host" "Remote host" 10 50
-      (Option.default "" state.remote_host)
+  (* Autodetect system memory. *)
+  let system_memory =
+    (* 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
-    | Yes [] -> Ask_again
-    | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+      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
 
-  let ask_port state =
-    match
-    inputbox "Remote port" "Remote port" 10 50
-      (Option.default "22" state.remote_port)
-    with
-    | Yes ([]|""::_) -> Next { state with remote_port = Some "22" }
-    | Yes (port::_) -> Next { state with remote_port = Some port }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+  (* Autodetect system # pCPUs. *)
+  let system_nr_cpus =
+    let cpus =
+      shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
+    match cpus with
+    | Some (cpus::_) -> int_of_string cpus
+    | _ -> 1 in
 
-  let ask_directory state =
-    let default_dir = "/var/lib/xen/images" in
-    match
-    inputbox "Remote directory" "Remote directory" 10 50
-      (Option.default default_dir state.remote_directory)
-    with
-    | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir }
-    | Yes (dir::_) -> Next { state with remote_directory = Some dir }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+  (* Greeting, type of transfer, network question stages.
+   * These are all done in newt mode.
+   *)
+  let config_transfer_type, config_network =
+    with_newt (
+      fun () ->
+	(* Greeting. *)
+	if !config_greeting then
+	  message_box program_name (sprintf "Welcome to %s, a live CD for migrating a physical machine to a virtualized host.\n\nTo continue press the Return key.\n\nTo get a shell you can use [ALT] [F2] and log in as root with no password.\n\nExtra information is logged in /tmp/virt-p2v.log but this file disappears when the machine reboots." program_name);
+
+	(* Type of transfer. *)
+	let config_transfer_type =
+	  match !config_transfer_type with
+	  | Some t -> t
+	  | None ->
+	      let items = [
+		"Physical to Virtual (P2V)", P2V;
+		"Virtual to Virtual (V2V)", V2V;
+	      ] in
+
+	      select_single ~stage:"Transfer type" 40
+		"Transfer type"
+		items in
+
+	(* Network configuration. *)
+	let config_network =
+	  match !config_network with
+	  | Some n -> n
+	  | None ->
+	      open_centered_window ~stage:"Network"
+		60 20 "Configure network";
+
+	      let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in
+	      Newt.listbox_set_width autolist 52;
+
+	      (* Populate the "Automatic" listbox with RHEL/Fedora
+	       * root partitions found which allow us to do
+	       * automatic configuration in a known way.
+	       *)
+	      let rec loop = function
+		| [] -> ()
+		| (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
+		  :: parts ->
+		    let label =
+		      sprintf "%s (%s)"
+			(dev_of_partition partition)
+			(string_of_linux_distro distro) in
+		    ignore (Newt.listbox_append_entry autolist label partition);
+		    loop parts
+		| _ :: parts -> loop parts
+	      in
+	      loop all_partitions;
+
+	      (* If there is no suitable root partition (the listbox
+	       * is empty) then disable the auto option and the listbox.
+	       *)
+	      let no_auto = Newt.listbox_item_count autolist = 0 in
+
+	      let auto =
+		Newt.radio_button 1 1
+		  "Automatic from:" (not no_auto) None in
+	      let shell =
+		Newt.radio_button 1 6
+		  "Start a shell" no_auto (Some auto) in
+
+	      if no_auto then (
+		Newt.component_takes_focus auto false;
+		Newt.component_takes_focus
+		  (Newt.component_of_listbox autolist) false
+	      );
 
-  let ask_username state =
-    let default_username = "root" in
-    match
-    inputbox "Remote username" "Remote username for ssh access to server" 10 50
-      (Option.default default_username state.remote_username)
-    with
-    | Yes ([]|""::_) ->
-	Next { state with remote_username = Some default_username }
-    | Yes (user::_) -> Next { state with remote_username = Some user }
-    | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+	      let qemu =
+		Newt.radio_button 1 7
+		  "QEMU user network" false (Some shell) in
+	      let nonet =
+		Newt.radio_button 1 8
+		  "No network or network already configured" false
+		  (Some qemu) in
+	      let static =
+		Newt.radio_button 1 9
+		  "Static configuration:" false (Some nonet) in
+
+	      let label1 = Newt.label 4 10 "Interface" in
+	      let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
+	      let label2 = Newt.label 4 11 "Address" in
+	      let entry2 = Newt.entry 16 11 None 16 [] in
+	      let label3 = Newt.label 4 12 "Netmask" in
+	      let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
+	      let label4 = Newt.label 4 13 "Gateway" in
+	      let entry4 = Newt.entry 16 13 None 16 [] in
+	      let label5 = Newt.label 4 14 "Nameserver" in
+	      let entry5 = Newt.entry 16 14 None 16 [] in
+
+	      let enable_static () =
+		Newt.component_takes_focus entry1 true;
+		Newt.component_takes_focus entry2 true;
+		Newt.component_takes_focus entry3 true;
+		Newt.component_takes_focus entry4 true;
+		Newt.component_takes_focus entry5 true
+	      in
+
+	      let disable_static () =
+		Newt.component_takes_focus entry1 false;
+		Newt.component_takes_focus entry2 false;
+		Newt.component_takes_focus entry3 false;
+		Newt.component_takes_focus entry4 false;
+		Newt.component_takes_focus entry5 false
+	      in
+
+	      let enable_autolist () =
+		Newt.component_takes_focus
+		  (Newt.component_of_listbox autolist) true
+	      in
+	      let disable_autolist () =
+		Newt.component_takes_focus
+		  (Newt.component_of_listbox autolist) false
+	      in
+
+	      disable_static ();
+	      Newt.component_add_callback auto
+		(fun () ->disable_static (); enable_autolist ());
+	      Newt.component_add_callback shell
+		(fun () -> disable_static (); disable_autolist ());
+	      Newt.component_add_callback qemu
+		(fun () -> disable_static (); disable_autolist ());
+	      Newt.component_add_callback nonet
+		(fun () -> disable_static (); disable_autolist ());
+	      Newt.component_add_callback static
+		(fun () -> enable_static (); disable_autolist ());
+
+	      let ok = Newt.button 48 16 "  OK  " in
+
+	      let form = Newt.form None None [] in
+	      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;
+					     ok];
+
+	      let n =
+		let rec loop () =
+		  ignore (Newt.run_form form);
+
+		  let r = Newt.radio_get_current auto in
+		  if Newt.component_equals r auto then (
+		    match Newt.listbox_get_current autolist with
+		    | None -> loop ()
+		    | Some part -> Auto part
+		  )
+		  else if Newt.component_equals r shell then Shell
+		  else if Newt.component_equals r qemu then QEMUUserNet
+		  else if Newt.component_equals r nonet then NoNetwork
+		  else if Newt.component_equals r static then (
+		    let interface = Newt.entry_get_value entry1 in
+		    let address = Newt.entry_get_value entry2 in
+		    let netmask = Newt.entry_get_value entry3 in
+		    let gateway = Newt.entry_get_value entry4 in
+		    let nameserver = Newt.entry_get_value entry5 in
+		    if interface = "" || address = "" ||
+		      netmask = "" || gateway = "" then
+			loop ()
+		    else
+		      Static (interface, address, netmask, gateway, nameserver)
+		  )
+		  else loop ()
+		in
+		loop () in
+	      Newt.pop_window ();
+
+	      n in
+
+	config_transfer_type, config_network
+    ) in
 
-  let ask_network state =
-    match
-    radiolist "Network configuration" "Network configuration" 12 50 4 [
-      "auto", "Automatic configuration", state.network = Some Auto;
-      "ask", "Ask for fixed IP address and gateway",
-        state.network = Some Static;
-      "sh", "Configure from the shell", state.network = Some Shell;
-      "qemu", "QEMU user network (for developers only)",
-        state.network = Some QEMUUserNet
-    ]
-    with
-    | Yes ("auto"::_) -> Next { state with network = Some Auto }
-    | Yes ("ask"::_) -> Next { state with network = Some Static }
-    | Yes ("sh"::_) -> Next { state with network = Some Shell }
-    | Yes ("qemu"::_) -> Next { state with network = Some QEMUUserNet }
-    | Yes _ | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+  (* Try to bring up the network. *)
+  (match config_network with
+   | Shell ->
+       printf "Network configuration.\n\n";
+       printf "Please configure the network from this shell.\n\n";
+       printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
+       shell ()
 
-  let ask_static_network_config state =
-    let interface, address, netmask, gateway, nameserver =
-      match state.static_network_config with
-      | Some (a,b,c,d,e) -> a,b,c,d,e
-      | None -> "eth0","","","","" in
-    match
-    form "Static network configuration" "Static network configuration"
-      13 50 5 [
-	"Interface",  1, 0, interface,  1, 12, 8,  0;
-	"Address",    2, 0, address,    2, 12, 16, 0;
-	"Netmask",    3, 0, netmask,    3, 12, 16, 0;
-	"Gateway",    4, 0, gateway,    4, 12, 16, 0;
-	"Nameserver", 5, 0, nameserver, 5, 12, 16, 0;
-      ]
-    with
-    | Yes (interface::address::netmask::gateway::nameserver::_) ->
-	Next { state with
-		 static_network_config = Some (interface, address, netmask,
-					       gateway, nameserver) }
-    | Yes _ | No | Help | Error -> Ask_again
-    | Back -> Prev
-  in
+   | Static (interface, address, netmask, gateway, nameserver) ->
+       printf "Trying static network configuration.\n\n%!";
+       if not (static_network
+		 (interface, address, netmask, gateway, nameserver)) then (
+	 printf "\nAuto-configuration failed.  Starting a shell.\n\n";
+	 printf "Please configure the network from this shell.\n\n";
+	 printf "When you have finished, exit the shell with ^D or exit.\n\n";
+	 shell ()
+       )
 
-  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
+   | Auto rootfs ->
+       printf
+	 "Trying network auto-configuration from root filesystem ...\n\n%!";
 
-  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
+       (* Mount the root filesystem read-only under /mnt/root. *)
+       sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");
 
-  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
+       if not (auto_network ()) then (
+	 printf "\nAuto-configuration failed.  Starting a shell.\n\n";
+	 printf "Please configure the network from this shell.\n\n";
+	 printf "When you have finished, exit the shell with ^D or exit.\n\n";
+	 shell ()
+       );
 
-  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
+       (* NB. Lazy unmount is required because dhclient keeps its current
+	* directory open on /etc/sysconfig/network-scripts/
+	*)
+       sh ("umount -l /mnt/root");
 
-  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
+   | QEMUUserNet ->
+       printf "Trying QEMU network configuration.\n\n%!";
+       qemu_network ()
 
-  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
+   | NoNetwork -> (* this is easy ... *) ()
+  );
 
-  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
+  (* SSH configuration phase. *)
+  let config_ssh =
+    with_newt (
+      fun () ->
+	match !config_ssh with
+	| Some c -> c
+	| None ->
+	    (* Query the user for SSH configuration. *)
+	    open_centered_window ~stage:"SSH configuration"
+	      60 20 "SSH configuration";
+
+	    let label1 = Newt.label 1 1 "Remote host" in
+	    let host = Newt.entry 20 1 None 36 [] in
+	    let label2 = Newt.label 1 2 "Remote port" in
+	    let port = Newt.entry 20 2 (Some "22") 6 [] in
+	    let label3 = Newt.label 1 3 "Remote directory" in
+	    let dir = Newt.entry 20 3 (Some "/var/lib/xen/images") 36 [] in
+	    let label4 = Newt.label 1 4 "SSH username" in
+	    let user = Newt.entry 20 4 (Some "root") 16 [] in
+	    (*
+	      There's no sensible way to support this for SSH:
+	    let label5 = Newt.label 1 5 "SSH password" in
+	    let pass = Newt.entry 20 5 None 16 [Newt.PASSWORD] in
+	    *)
+
+	    let compr =
+	      Newt.checkbox 16 7 "Use SSH compression (not good for LANs)"
+		' ' None in
+
+	    let check = Newt.checkbox 16 9 "Test SSH connection" '*' None in
+
+	    let ok = Newt.button 48 16 "  OK  " in
+
+	    let form = Newt.form None None [] in
+	    Newt.form_add_components form [label1;label2;label3;label4;
+					   host;port;dir;user;
+					   compr;check;
+					   ok];
+
+	    let c =
+	      let rec loop () =
+		ignore (Newt.run_form form);
+		let host = Newt.entry_get_value host in
+		let port = Newt.entry_get_value port in
+		let dir = Newt.entry_get_value dir in
+		let user = Newt.entry_get_value user in
+		let compr = Newt.checkbox_get_value compr = '*' in
+		let check = Newt.checkbox_get_value check = '*' in
+		if host <> "" && port <> "" && user <> "" then
+		    { ssh_host = host; ssh_port = port; ssh_directory = dir;
+		      ssh_username = user;
+		      ssh_compression = compr;
+		      ssh_check = check; }
+		else
+		  loop ()
+	      in
+	      loop () 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"
-         (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 -> "")
-      )
-      21 50
-    with
-    | Yes _ -> Next state
-    | Back -> Prev
-    | No | Help | Error -> Ask_again
-  in
+	    Newt.pop_window ();
+	    c
+    ) 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.
-   *)
-  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_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
+  (* If asked, check the SSH connection. *)
+  if config_ssh.ssh_check then
+    if not (test_ssh config_ssh) then
+      failwith "SSH configuration failed";
+
+  (* 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 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 libvirtd =
+		Newt.checkbox 12 14 "Use remote libvirtd" '*' None in
+
+	      let ok = Newt.button 28 16 "  OK  " 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
+
+	      Newt.pop_window ();
+
+	      c in
+
+	config_devices_to_send, config_root_filesystem, config_target
+    ) in
 
-  eprintf "finished dialog loop\n%!";
+  (* Try to get the capabilities from the remote machine.  If we fail
+   * it doesn't matter too much.
+   *)
+  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;
 
   (* Switch LVM config. *)
   sh "vgchange -a n";
@@ -1157,28 +1436,26 @@ MAC address:  %s"
   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
@@ -1191,106 +1468,36 @@ MAC address:  %s"
        sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
   );
 
-  (* See if we can do network configuration. *)
-  let network = Option.get state.network in
-  (match network with
-   | Shell ->
-       printf "Network configuration.\n\n";
-       printf "Please configure the network from this shell.\n\n";
-       printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
-       shell ()
-
-   | Static ->
-       printf "Trying static network configuration.\n\n%!";
-       if not (static_network state) then (
-	 printf "\nAuto-configuration failed.  Starting a shell.\n\n";
-	 printf "Please configure the network from this shell.\n\n";
-	 printf "When you have finished, exit the shell with ^D or exit.\n\n";
-	 shell ()
-       )
-
-   | Auto ->
-       printf
-	 "Trying network auto-configuration from root filesystem ...\n\n%!";
-       if not (auto_network state) then (
-	 printf "\nAuto-configuration failed.  Starting a shell.\n\n";
-	 printf "Please configure the network from this shell.\n\n";
-	 printf "When you have finished, exit the shell with ^D or exit.\n\n";
-	 shell ()
-       )
-   | QEMUUserNet ->
-       printf "Trying QEMU network configuration.\n\n%!";
-       qemu_network ()
-  );
-
   (* 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
-
-  (* 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
-
-  (* Autodetect system # pCPUs. *)
-  let system_nr_cpus =
-    let cpus =
-      shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
-    match cpus with
-    | Some (cpus::_) -> int_of_string cpus
-    | _ -> 1 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
-
-  (* Functions to connect and disconnect from the remote system. *)
-  let do_connect remote_name _ =
-    let cmd = sprintf "ssh -C -l %s -p %s %s \"cat > %s/%s\""
-      (quote remote_username) (quote remote_port) (quote remote_host)
-      (quote remote_directory) (quote remote_name) in
-    eprintf "connect: %s\n%!" cmd;
-    let chan = open_process_out cmd in
-    descr_of_out_channel chan, chan
-  in
-  let do_disconnect (_, chan) =
-    match close_process_out chan with
-    | WEXITED 0 -> ()		(* OK *)
-    | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
-    | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
-    | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
-  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.
@@ -1302,11 +1509,11 @@ MAC address:  %s"
     "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
@@ -1321,23 +1528,6 @@ MAC address:  %s"
    *)
   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
@@ -1347,15 +1537,17 @@ MAC address:  %s"
     (* 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";
@@ -1373,7 +1565,8 @@ MAC address:  %s"
 	  [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"]])]
@@ -1383,7 +1576,7 @@ MAC address:  %s"
     (* <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 ->
@@ -1394,7 +1587,8 @@ MAC address:  %s"
 	    [] 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"],
@@ -1408,10 +1602,11 @@ MAC address:  %s"
 	  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", [],
@@ -1421,7 +1616,7 @@ MAC address:  %s"
     (* 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"]
@@ -1436,7 +1631,7 @@ MAC address:  %s"
     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 "\
@@ -1451,10 +1646,10 @@ MAC address:  %s"
     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
@@ -1476,63 +1671,72 @@ MAC address:  %s"
       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
       let bufsize = 1024 * 1024 in
       let buffer = String.create bufsize in
       let start = gettimeofday () in
 
-      let rec copy bytes_sent last_printed_at =
+      let rec copy bytes_sent last_printed_at spinner =
 	let n = read fd buffer 0 bufsize in
 	if n > 0 then (
-	  ignore (write sock buffer 0 n);
+	  let n' = write sock buffer 0 n in
+	  if n <> n' then assert false; (* never, according to the manual *)
 
 	  let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
-	  let last_printed_at =
+	  let last_printed_at, spinner =
 	    let now = gettimeofday () in
 	    (* Print progress every few seconds. *)
-	    if now -. last_printed_at > 5. then (
+	    if now -. last_printed_at > 2. then (
 	      let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
 	      let secs_elapsed = now -. start in
-	      printf "%.0f%%" (100. *. elapsed);
+	      printf "%.0f%% %c %.1f Mbps"
+		(100. *. elapsed) spinners.[spinner]
+	        (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
 	      (* After 60 seconds has elapsed, start printing estimates. *)
 	      if secs_elapsed >= 60. then (
 		let remaining = 1. -. elapsed in
 		let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
 		if secs_remaining > 120. then
-		  printf " (about %.0f minutes remaining)          "
-		    (secs_remaining /. 60.)
+		  printf " (about %.0f minutes remaining)" (secs_remaining/.60.)
 		else
-		  printf " (about %.0f seconds remaining)          "
+		  printf " (about %.0f seconds remaining)"
 		    secs_remaining
 	      );
-	      printf "\r%!";
-	      now
+	      printf "          \r%!";
+	      let spinner = (spinner + 1) mod String.length spinners in
+	      now, spinner
 	    )
-	    else last_printed_at in
+	    else last_printed_at, spinner in
 
-	  copy bytes_sent last_printed_at
+	  copy bytes_sent last_printed_at spinner
 	)
       in
-      copy 0L start;
+      copy 0L start 0;
+      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 "virt-p2v completed"
+    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
 
+(*----------------------------------------------------------------------*)
+
 let usage () =
   eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
   exit 2
@@ -1543,7 +1747,9 @@ let usage () =
  *)
 let handle_exn f arg =
   try f arg
-  with exn -> print_endline (Printexc.to_string exn); raise exn
+  with exn ->
+    print_endline (Printexc.to_string exn);
+    raise exn
 
 (* Test harness for the Makefile.  The Makefile invokes this script as
  * 'virt-p2v --test' just to check it compiles.  When it is running