[virt-p2v.git] / virt-p2v

#!/usr/bin/ocamlrun /usr/bin/ocaml
(* -*- tuareg -*- *)
(* virt-p2v is a script which performs a physical to
 * virtual conversion of local disks.
 *
 * Copyright (C) 2007-2008 Red Hat Inc.
 * Written by Richard W.M. Jones <rjones@redhat.com>
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)

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 hypervisor =
  | Xen
  | QEMU
  | KVM
type architecture =
  | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
  | OtherArch of string
  | UnknownArch

(*----------------------------------------------------------------------*)
(* 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
 * then you will get a custom virt-p2v which is partially or even fully
 * automated and won't ask the user any questions.
 *
 * 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.
 *)

(* 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_remote_host = ref None
let config_remote_port = ref None
let config_remote_directory = ref None
let config_remote_username = ref None
let config_remote_password = ref None
let config_ssh_check = ref None
let config_libvirtd_check = ref None

(* What to transfer. *)
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_compression = 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";;*)
#directory "/home/rjones/d/redhat/newt";;
#load "mlnewt.cma";;
#directory "+xml-light";;
#load "xml-light.cma";;

open Unix
open Printf
open ExtList
open ExtString

(*----------------------------------------------------------------------*)
(* General helper functions. *)

let sort_uniq ?(cmp = compare) xs =     (* sort and uniq a list *)
  let xs = List.sort ~cmp xs in
  let rec loop = function
    | [] -> [] | [x] -> [x]
    | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
    | x :: xs -> x :: loop xs
  in
  loop xs

let input_all_lines chan =
  let lines = ref [] in
  try
    while true do lines := input_line chan :: !lines done; []
  with
    End_of_file -> List.rev !lines

let dev_of_partition = function
  | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
  | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv

let string_of_architecture = function
  | I386 -> "i386"
  | X86_64 -> "x86_64"
  | IA64 -> "ia64"
  | PPC -> "ppc"
  | PPC64 -> "ppc64"
  | SPARC -> "sparc"
  | SPARC64 -> "sparc64"
  | OtherArch arch -> arch
  | UnknownArch -> ""

type nature = LinuxSwap
            | LinuxRoot of architecture * linux_distro
            | WindowsRoot               (* Windows C: *)
            | LinuxBoot                 (* Linux /boot *)
            | NotRoot                   (* mountable, but not / or /boot *)
            | UnknownNature
and linux_distro = RHEL of int * int
                 | Fedora of int
                 | Debian of int * int
                 | OtherLinux

let rec string_of_nature = function
  | LinuxSwap -> "Linux swap"
  | LinuxRoot (architecture, distro) ->
      string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
  | WindowsRoot -> "Windows root"
  | LinuxBoot -> "Linux /boot"
  | NotRoot -> "Mountable non-root"
  | UnknownNature -> "Unknown"
and string_of_linux_distro = function
  | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
  | Fedora v -> sprintf "Fedora %d" v
  | Debian (a,b) -> sprintf "Debian %d.%d" a b
  | OtherLinux -> "Linux"

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.
 *
 * 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 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
  )

(* 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_component form textbox;
      Newt.form_add_component form ok;

      Newt.component_takes_focus ok true;

      ignore (Newt.run_form form);
      Newt.pop_window ()
  )

(* 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

(* Shell-safe quoting function.  In fact there's one in stdlib so use it. *)
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 failwith (sprintf "Command failed:\n\n%s" cmd)

let shfailok cmd =
  eprintf "shfailok: %s\n%!" cmd;
  ignore (Sys.command cmd)

let shwithstatus cmd =
  eprintf "shwithstatus: %s\n%!" cmd;
  Sys.command cmd

(* Same as `cmd` in shell.  Any error message will be in the logfile. *)
let shget cmd =
  eprintf "shget: %s\n%!" cmd;
  let chan = open_process_in cmd in
  let lines = input_all_lines chan in
  match close_process_in chan with
  | WEXITED 0 -> Some lines             (* command succeeded *)
  | WEXITED _ -> None                   (* command failed *)
  | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
  | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)

(* Start an interactive shell.  Need to juggle file descriptors a bit
 * because bash write PS1 to stderr (currently directed to the logfile).
 *)
let shell () =
  match fork () with
  | 0 ->                                (* child, runs bash *)
      close stderr;
      dup2 stdout stderr;
      (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
      ignore (
        Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
      )
  | _ ->                                (* parent, waits *)
      eprintf "waiting for subshell to exit\n%!";
      ignore (wait ())

(* Some true if is dir/file, Some false if not, None if not found. *)
let is_dir path =
  try Some ((stat path).st_kind = S_DIR)
  with Unix_error (ENOENT, "stat", _) -> None
let is_file path =
  try Some ((stat path).st_kind = S_REG)
  with Unix_error (ENOENT, "stat", _) -> None

(*----------------------------------------------------------------------*)
(* P2V-specific helper functions. *)

(* Generate a predictable safe name containing only letters, numbers
 * and underscores.  If passed a string with no letters or numbers,
 * generates "_1", "_2", etc.
 *)
let safe_name =
  let next_anon =
    let i = ref 0 in
    fun () -> incr i; "_" ^ string_of_int !i
  in
  fun name ->
    let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
    let name = String.copy name in
    let have_safe = ref false in
    for i = 0 to String.length name - 1 do
      if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
    done;
    if !have_safe then name else next_anon ()

type block_device = string * int64      (* "hda" & size in bytes *)

(* Parse the output of 'lvs' to get list of LV names, sizes,
 * corresponding PVs, etc.  Returns a list of (lvname, PVs, lvsize).
 *)
let get_lvs =
  let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in

  function () ->
    match
    shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
    with
    | None -> []
    | Some lines ->
        let lines = List.map Pcre.split lines in
        List.map (
          function
          | [vg; lv; pvs; lvsize]
          | [_; vg; lv; pvs; lvsize] ->
              let pvs = String.nsplit pvs "," in
              let pvs = List.filter_map (
                fun pv ->
                  try
                    let subs = Pcre.exec ~rex:devname pv in
                    Some (Pcre.get_substring subs 1)
                  with
                    Not_found ->
                      eprintf "lvs: unexpected device name: %s\n%!" pv;
                      None
              ) pvs in
              LV (vg, lv), pvs, lvsize
          | line ->
              failwith ("lvs: unexpected output: " ^ String.concat "," line)
        ) lines

(* Get the partitions on a block device.
 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
 *)
let get_partitions dev =
  let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
  let devdir = "/sys/block/" ^ dev in
  let parts = Sys.readdir devdir in
  let parts = Array.to_list parts in
  let parts = List.filter (
    fun name -> Some true = is_dir (devdir ^ "/" ^ name)
  ) parts in
  let parts = List.filter_map (
    fun part ->
      try
        let subs = Pcre.exec ~rex part in
        Some (Part (dev, Pcre.get_substring subs 1))
      with
        Not_found -> None
  ) parts in
  parts

(* Generate snapshot device name from device name. *)
let snapshot_name dev =
  "snap" ^ (safe_name dev)

(* Perform a device-mapper snapshot with ramdisk overlay. *)
let snapshot =
  let next_free_ram_disk =
    let i = ref 0 in
    fun () -> incr i; "/dev/ram" ^ string_of_int !i
  in
  fun origin_dev snapshot_dev ->
    let ramdisk = next_free_ram_disk () in
    let sectors =
      let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
      let lines = shget cmd in
      match lines with
      | Some (sectors::_) -> Int64.of_string sectors
      | Some [] | None ->
          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'"
          snapshot_dev sectors origin_dev);
    (* Create the snapshot. *)
    sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
          snapshot_dev sectors snapshot_dev ramdisk)

(* Try to perform automatic network configuration, assuming a Fedora or
 * RHEL-like root filesystem mounted on /mnt/root.
 *)
let auto_network () =
  (* Fedora gives an error if this file doesn't exist. *)
  sh "touch /etc/resolv.conf";

  (* NB. Lazy unmount is required because dhclient keeps its current
   * directory open on /etc/sysconfig/network-scripts/
   *)
  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 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 !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) %!";
    let line = read_line () in
    String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
  )
  else
    (* Non-interactive: return the status of /etc/init.d/network start. *)
    status = 0

(* Configure the network statically. *)
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";
  sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"

(* Map local device names to remote devices names.  At the moment we
 * just change sd* to hd* (as device names appear under fullvirt).  In
 * future, lots of complex possibilities.
 *)
let remote_of_origin_dev =
  let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
  let devsd_subst = Pcre.subst "hd$1" in
  fun dev ->
    Pcre.replace ~rex:devsd ~itempl:devsd_subst dev

(* Rewrite /mnt/root/etc/fstab. *)
let rewrite_fstab state devices_to_send =
  let filename = "/mnt/root/etc/fstab" in
  if is_file filename = Some true then (
    sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));

    let chan = open_in filename in
    let lines = input_all_lines chan in
    close_in chan;
    let lines = List.map Pcre.split lines in
    let lines = List.map (
      function
      | dev :: rest when String.starts_with dev "/dev/" ->
          let dev = String.sub dev 5 (String.length dev - 5) in
          let dev = remote_of_origin_dev dev in
          let dev = "/dev/" ^ dev in
          dev :: rest
      | line -> line
    ) lines in

    let chan = open_out filename in
    List.iter (
      function
      | [dev; mountpoint; fstype; options; freq; passno] ->
          fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
            dev mountpoint fstype options freq passno
      | line ->
          output_string chan (String.concat " " line);
          output_char chan '\n'
    ) lines;
    close_out chan
  )

(* Generate a random MAC address in the Xen-reserved space. *)
let random_mac_address () =
  let random =
    List.map (sprintf "%02x") (
      List.map (fun _ -> Random.int 256) [0;0;0]
    ) in
  String.concat ":" ("00"::"16"::"3e"::random)

(* Generate a random UUID. *)
let random_uuid =
  let hex = "0123456789abcdef" in
  fun () ->
  let str = String.create 32 in
  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.
   *)
  putenv "PATH"
    (String.concat ":"
       ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
        "/usr/bin"; "/bin"]);
  putenv "HOME" "/root";
  putenv "LOGNAME" "root";

  (* We can safely write in /tmp (it's a synthetic live CD directory). *)
  chdir "/tmp";

  (* Set up logging to /tmp/virt-p2v.log. *)
  let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
  dup2 fd stderr;
  close fd;

  (* Log the start up time. *)
  eprintf "\n\n**************************************************\n\n";
  let tm = localtime (time ()) in
  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. *)
  (match ttyname with
   | None -> ()
   | Some ttyname ->
       let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
       dup2 fd stdin;
       dup2 fd stdout;
       close fd);
  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 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.";

  (* Start of the information gathering phase. *)
  printf "%s detecting hard drives (this may take some time) ...\n%!"
    program_name;

  (* 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".
   *)
  let all_block_devices : block_device list =
    let rex = Pcre.regexp "^[hs]d" in
    let devices = Array.to_list (Sys.readdir "/sys/block") in
    let devices = List.sort devices in
    let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
    eprintf "all_block_devices: block devices: %s\n%!"
      (String.concat "; " devices);
    (* Run blockdev --getsize64 on each, and reject any where this fails
     * (probably removable devices).
     *)
    let devices = List.filter_map (
      fun d ->
        let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
        let lines = shget cmd in
        match lines with
        | Some (blksize::_) -> Some (d, Int64.of_string blksize)
        | Some [] | None -> None
    ) devices in
    eprintf "all_block_devices: non-removable block devices: %s\n%!"
      (String.concat "; "
         (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
    if devices = [] then
      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
   * filesystem directly).  We refer to these generically as
   * "partitions".
   *)
  let all_partitions : partition list =
    (* LVs & PVs. *)
    let lvs, pvs =
      let lvs = get_lvs () in
      let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
      let pvs = List.concat pvs in
      let pvs = sort_uniq pvs in
      eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
      let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
      eprintf "all_partitions: LVs: %s\n%!"
        (String.concat "; " (List.map dev_of_partition lvs));
      lvs, pvs in

    (* Partitions (eg. "sda1", "sda2"). *)
    let parts =
      let parts = List.map fst all_block_devices in
      let parts = List.map get_partitions parts in
      let parts = List.concat parts in
      eprintf "all_partitions: all partitions: %s\n%!"
        (String.concat "; " (List.map dev_of_partition parts));

      (* Remove any partitions which are PVs. *)
      let parts = List.filter (
        function
        | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
        | LV _ -> assert false
      ) parts in
      parts in
    eprintf "all_partitions: partitions after removing PVs: %s\n%!"
      (String.concat "; " (List.map dev_of_partition parts));

    (* Concatenate LVs & Parts *)
    lvs @ parts in

  (* Try to determine the nature of each partition.
   * Root? Swap? Architecture? etc.
   *)
  let all_partitions : (partition * nature) list =
    (* Output of 'file' command for Linux swap file. *)
    let swap = Pcre.regexp "Linux.*swap.*file" in
    (* Contents of /etc/redhat-release. *)
    let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
    let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
    (* Contents of /etc/debian_version. *)
    let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
    (* Output of 'file' on certain executables. *)
    let i386 = Pcre.regexp ", Intel 80386," in
    let x86_64 = Pcre.regexp ", x86-64," in
    let itanic = Pcre.regexp ", IA-64," in

    (* Examine the filesystem mounted on 'mnt' to determine the
     * operating system, and, if Linux, the distro.
     *)
    let detect_os mnt =
      if is_dir (mnt ^ "/Windows") = Some true &&
        is_file (mnt ^ "/autoexec.bat") = Some true then
          WindowsRoot
      else if is_dir (mnt ^ "/etc") = Some true &&
        is_dir (mnt ^ "/sbin") = Some true &&
        is_dir (mnt ^ "/var") = Some true then (
          if is_file (mnt ^ "/etc/redhat-release") = Some true then (
            let chan = open_in (mnt ^ "/etc/redhat-release") in
            let lines = input_all_lines chan in
            close_in chan;

            match lines with
            | [] -> (* empty /etc/redhat-release ...? *)
                LinuxRoot (UnknownArch, OtherLinux)
            | line::_ -> (* try to detect OS from /etc/redhat-release *)
                try
                  let subs = Pcre.exec ~rex:rhel line in
                  let major = int_of_string (Pcre.get_substring subs 1) in
                  let minor =
                    try int_of_string (Pcre.get_substring subs 2)
                    with Not_found -> 0 in
                  LinuxRoot (UnknownArch, RHEL (major, minor))
                with
                  Not_found | Failure "int_of_string" ->
                    try
                      let subs = Pcre.exec ~rex:fedora line in
                      let version = int_of_string (Pcre.get_substring subs 1) in
                      LinuxRoot (UnknownArch, Fedora version)
                    with
                      Not_found | Failure "int_of_string" ->
                        LinuxRoot (UnknownArch, OtherLinux)
          )
          else if is_file (mnt ^ "/etc/debian_version") = Some true then (
            let chan = open_in (mnt ^ "/etc/debian_version") in
            let lines = input_all_lines chan in
            close_in chan;

            match lines with
            | [] -> (* empty /etc/debian_version ...? *)
                LinuxRoot (UnknownArch, OtherLinux)
            | line::_ -> (* try to detect version from /etc/debian_version *)
                try
                  let subs = Pcre.exec ~rex:debian line in
                  let major = int_of_string (Pcre.get_substring subs 1) in
                  let minor = int_of_string (Pcre.get_substring subs 2) in
                  LinuxRoot (UnknownArch, Debian (major, minor))
                with
                  Not_found | Failure "int_of_string" ->
                    LinuxRoot (UnknownArch, OtherLinux)
          )
          else
            LinuxRoot (UnknownArch, OtherLinux)
        ) else if is_dir (mnt ^ "/grub") = Some true &&
          is_file (mnt ^ "/grub/stage1") = Some true then (
            LinuxBoot
        ) else
          NotRoot (* mountable, but not a root filesystem *)
    in

    (* Examine the Linux root filesystem mounted on 'mnt' to
     * determine the architecture. We do this by looking at some
     * well-known binaries that we expect to be there.
     *)
    let detect_architecture mnt =
      let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
      match shget cmd with
      | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
      | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
      | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
      | _ -> UnknownArch
    in

    List.map (
      fun part ->
        let dev = dev_of_partition part in (* Get /dev device. *)

        let nature =
          (* Use 'file' command to detect if it is swap. *)
          let cmd = "file -sbL " ^ quote dev in
          match shget cmd with
          | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
          | _ ->
              (* Blindly try to mount the device. *)
              let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
              match shwithstatus cmd with
              | 0 ->
                  let os = detect_os "/mnt/root" in
                  let nature =
                    match os with
                    | LinuxRoot (UnknownArch, distro) ->
                        let architecture = detect_architecture "/mnt/root" in
                        LinuxRoot (architecture, distro)
                    | os -> os in
                  sh "umount /mnt/root";
                  nature

              | _ -> UnknownNature (* not mountable *)

        in

        eprintf "partition detection: %s is %s\n%!"
          dev (string_of_nature nature);

        (part, nature)
    ) all_partitions
  in

  printf "finished detecting hard drives\n%!";

  (* 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

  (* 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 rec loop () =
                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];
                Newt.form_add_component form ok;

                ignore (Newt.run_form form);
                Newt.pop_window ();

                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

        (* Network configuration. *)
        let config_network =
          match !config_network with
          | Some n -> n
          | None ->
              let rec loop () =
                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 partition_map = Hashtbl.create 13 in
                let maplen = ref 1 in
                let rec iloop = function
                  | [] -> ()
                  | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
                    :: parts ->
                      let label =
                        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;
                      iloop parts
                  | _ :: parts -> iloop parts
                in
                iloop all_partitions;

                (* 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 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 autolist false
                );

                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 autolist true
                in
                let disable_autolist () =
                  Newt.component_takes_focus 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 28 16 "  OK  " in

                let form = Newt.form None None [] in
                Newt.form_add_component form auto;
                Newt.form_add_component form autolist;
                Newt.form_add_components form [shell;qemu;nonet;static];
                Newt.form_add_components form
                  [label1;label2;label3;label4;label5];
                Newt.form_add_components form
                  [entry1;entry2;entry3;entry4;entry5];
                Newt.form_add_component form ok;

                ignore (Newt.run_form form);
                Newt.pop_window ();

                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 i -> Auto (Hashtbl.find partition_map i)
                )
                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

        config_transfer_type, config_network
    ) 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 ()

   | 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 ()
       )

   | Auto rootfs ->
       printf
         "Trying network auto-configuration from root filesystem ...\n\n%!";

       (* Mount the root filesystem read-only under /mnt/root. *)
       sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");

       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 ()
       );

       (* NB. Lazy unmount is required because dhclient keeps its current
        * directory open on /etc/sysconfig/network-scripts/
        *)
       sh ("umount -l /mnt/root");

   | QEMUUserNet ->
       printf "Trying QEMU network configuration.\n\n%!";
       qemu_network ()

   | NoNetwork -> (* this is easy ... *) ()
  );

(*
  let ask_hostname state =
    match
    inputbox "Remote host" "Remote host" 10 50
      (Option.default "" state.remote_host)
    with
    | Yes [] -> Ask_again
    | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
    | No | Help | Error -> Ask_again
    | Back -> Prev
  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

  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

  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 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

  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 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 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 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 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

  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

  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

  (* 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_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
   * hard disk.
   *)
  if test_dialog_stages then exit 1;

  (* Switch LVM config. *)
  sh "vgchange -a n";
  putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
  sh "rm -f /etc/lvm/cache/.cache";
  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 =
    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

  (* Run kpartx on the snapshots. *)
  List.iter (
    fun (origin, snapshot) ->
      shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
  ) 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
   | Part (dev, partnum) ->
       let dev = dev ^ partnum in
       let snapshot_dev = snapshot_name dev in
       sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")

   | LV (vg, lv) ->
       (* The LV will be backed by a snapshot device, so just mount
        * directly.
        *)
       sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
  );

  (* Work out what devices will be called at the remote end. *)
  let 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

  (* Modify files on the root filesystem. *)
  rewrite_fstab state 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. *)
        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

  (* Functions to connect and disconnect from the remote system. *)
  let do_connect remote_name _ =
    let cmd = sprintf "ssh%s -l %s -p %s %s \"cat > %s/%s\""
      (if state.compression = Some false then "" else " -C")
      (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

  (* XXX This is using the hostname derived from network configuration
   * above.  We might want to ask the user to choose.
   *)
  let hostname = safe_name (gethostname ()) in
  let basename =
    let date = sprintf "%04d%02d%02d%02d%02d"
      (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
    "p2v-" ^ hostname ^ "-" ^ date in

  (* Work out what the image filenames will be at the remote end. *)
  let 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

  (* 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
   * always get well-formed XML.
   *
   * XXX For some of the stuff here we really should do a
   * virConnectGetCapabilities call to the remote host first.
   *
   * XXX There is a case for using virt-install to generate this XML.
   * When we start to incorporate libvirt access & storage API this
   * needs to be rethought.
   *)
  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
    (* ... and the _other_ sort of leaf (god I hate XML). *)
    let tleaf name attribs = Xml.Element (name, attribs, []) in

    (* 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

    (* Top-level stuff which differs for each HV type (isn't this supposed
     * to be portable ...)
     *)
    let extras =
      match state.hypervisor with
      | Some Xen ->
          [Xml.Element ("os", [],
                        [leaf "type" "hvm";
                         leaf "loader" "/usr/lib/xen/boot/hvmloader";
                         tleaf "boot" ["dev", "hd"]]);
           Xml.Element ("features", [],
                        [tleaf "pae" [];
                         tleaf "acpi" [];
                         tleaf "apic" []]);
           tleaf "clock" ["sync", "localtime"]]
      | Some KVM ->
          [Xml.Element ("os", [], [leaf "type" "hvm"]);
           tleaf "clock" ["sync", "localtime"]]
      | Some QEMU ->
          [Xml.Element ("os", [],
                        [Xml.Element ("type",
                                      ["arch",
                                       string_of_architecture architecture;
                                       "machine","pc"],
                                      [Xml.PCData "hvm"]);
                         tleaf "boot" ["dev", "hd"]])]
      | None ->
          [] in

    (* <devices> section. *)
    let devices =
      let emulator =
        match state.hypervisor with
        | Some Xen ->
            [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
        | Some QEMU ->
            [leaf "emulator" "/usr/bin/qemu"]
        | Some KVM ->
            [leaf "emulator" "/usr/bin/qemu-kvm"]
        | None ->
            [] in
      let interface =
        Xml.Element ("interface", ["type", "user"],
                     [tleaf "mac" ["address", mac_address]]) in
      (* XXX should have an option for Xen bridging:
        Xml.Element (
        "interface", ["type","bridge"],
        [tleaf "source" ["bridge","xenbr0"];
        tleaf "mac" ["address",mac_address];
        tleaf "script" ["path","vif-bridge"]])*)
      let graphics = tleaf "graphics" ["type", "vnc"] in

      let disks = List.map (
        fun (_, _, remote_dev, remote_name) ->
          Xml.Element (
            "disk", ["type", "file";
                     "device", "disk"],
            [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
             tleaf "target" ["dev", remote_dev]]
          )
      ) devices_to_send in

      Xml.Element (
        "devices", [],
        emulator @ interface :: graphics :: disks
      ) in

    (* Put it all together in <domain type='foo'>. *)
    Xml.Element (
      "domain",
      (match state.hypervisor with
       | Some Xen -> ["type", "xen"]
       | Some QEMU -> ["type", "qemu"]
       | Some KVM -> ["type", "kvm"]
       | None -> []),
      name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
    ) in

  (* Convert XML configuration file to a string, then send it to the
   * remote server.
   *)
  let () =
    let xml = Xml.to_string_fmt xml in

    let conn_arg =
      match state.hypervisor with
      | Some Xen | None -> ""
      | Some QEMU | Some KVM -> " -c qemu:///system" in
    let xml = sprintf "\
<!--
  This is a libvirt configuration file.

  To start the domain, do:
    virsh%s define %s
    virsh%s start %s
-->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in

    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
    (* In OCaml this actually loops calling write(2) *)
    ignore (write sock xml 0 xml_len);
    do_disconnect conn in

  (* Send the device snapshots to the remote host. *)
  (* XXX This code should be made more robust against both network
   * errors and local I/O errors.  Also should allow the user several
   * attempts to connect, or let them go back to the dialog stage.
   *)
  List.iter (
    fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
      eprintf "sending %s as %s\n%!" origin_dev remote_name;

      let size =
        try List.assoc origin_dev all_block_devices
        with Not_found -> assert false (* internal error *) in

      printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
        ((Int64.to_float size) /. (1024.*.1024.*.1024.));

      (* Open the snapshot device. *)
      let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in

      (* Now connect. *)
      let (sock,_) as conn = do_connect remote_name size 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 spinner =
        let n = read fd buffer 0 bufsize in
        if n > 0 then (
          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, spinner =
            let now = gettimeofday () in
            (* Print progress every few seconds. *)
            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%% %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.)
                else
                  printf " (about %.0f seconds remaining)"
                    secs_remaining
              );
              printf "          \r%!";
              let spinner = (spinner + 1) mod String.length spinners in
              now, spinner
            )
            else last_printed_at, spinner in

          copy bytes_sent last_printed_at spinner
        )
      in
      copy 0L start 0;
      printf "\n\n%!"; (* because of the messages printed above *)

      (* Disconnect. *)
      do_disconnect conn
  ) devices_to_send;

  (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)

  (* Clean up and reboot. *)
  ignore (
    msgbox (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
  );

  shfailok "eject";
  shfailok "reboot";
*)
  exit 0

(*----------------------------------------------------------------------*)

let usage () =
  eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
  exit 2

(* Make sure that exceptions from 'main' get printed out on stdout
 * as well as stderr, since stderr is probably redirected to the
 * logfile, and so not visible to the user.
 *)
let handle_exn f arg =
  try f arg
  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
 * from the actual live CD, there is a single parameter which is the
 * tty name (so usually 'virt-p2v tty1').
 *)
let () =
  match Array.to_list Sys.argv with
  | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
  | [ _; "--test" ] -> ()               (* Makefile test - do nothing. *)
  | [ _; ttyname ] ->                   (* Run main with ttyname. *)
      handle_exn main (Some ttyname)
  | [ _ ] ->                            (* Interactive - no ttyname. *)
      handle_exn main None
  | _ -> usage ()

(* This file must end with a newline *)