Pull in non-essential parts of the V2P patch.

[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 transfer =
  | P2V                                 (* physical to virtual *)
  | V2V                                 (* virtual to virtual *)
  (*| V2P*)                             (* virtual to physical - not impl *)
type partition =
  | Part of string * string             (* eg. "hda", "1" *)
  | LV of string * string               (* eg. "VolGroup00", "LogVol00" *)
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.
 *
 * 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_ssh = ref None

(* What to transfer. *)
let config_devices_to_send = ref None

(* The root filesystem - parts of this get modified after migration. *)
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. *)
;;
#use "topfind";;
#require "extlib";;
#require "pcre";;
#require "newt";;
#require "xml-light";;
#require "gettext-stub";;
#require "libvirt";;

open Unix
open Printf
open ExtList
open ExtString

(*----------------------------------------------------------------------*)
(* Gettext support.
 *
 * Use s_ "string" to mark a translatable string, and f_ "string %s"
 * to mark a format string (eg. for printf).  There are other
 * functions: see ocaml-gettext manual and GNU gettext info.
 *
 * Try not to mark strings which always go to the log file (eg.
 * eprintf messages).
 *)

module P2VGettext = Gettext.Program (
  struct
    let textdomain   = "virt-p2v"
    let codeset      = None
    let dir          = None
    let dependencies = []
  end
) (GettextStub.Native)
open P2VGettext

let supported_langs =
  (* Note these strings are NOT translated! *)
  let nonasian_langs = [
    "English", "en_US.UTF-8";
  ] in
  let asian_langs = [
    "\xE6\x97\xA5\xE6\x9C\xAC\xE8\xAA\x9E (Japanese)", "ja_JP.UTF-8"
  ] in
  (* Linux console doesn't support Asian or RTL languages. *)
  let term = try getenv "TERM" with Not_found -> "" in
  match term with
  | "linux" -> nonasian_langs
  | _       -> nonasian_langs @ asian_langs

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

let architecture_of_string = function
  | str when
      String.length str = 4 &&
      (str.[0] = 'i' || str.[0] = 'I') &&
      (str.[1] >= '3' && str.[1] <= '6') &&
      str.[2] = '8' && str.[3] = '6' -> I386
  | "x86_64" | "X86_64" | "x86-64" | "X86-64" -> X86_64
  | "ia64" | "IA64" -> IA64
  | "ppc" | "PPC" | "ppc32" | "PPC32" -> PPC
  | "ppc64" | "PPC64" -> PPC64
  | "sparc" | "SPARC" | "sparc32" | "SPARC32" -> SPARC
  | "sparc64" | "SPARC64" -> SPARC64
  | "" -> UnknownArch
  | str -> OtherArch str

type wordsize =
  | W32 | W64 | WUnknown

let wordsize_of_architecture = function
  | I386 -> W32
  | X86_64 -> W64
  | IA64 -> W64
  | PPC -> W32
  | PPC64 -> W64
  | SPARC -> W32
  | SPARC64 -> W64
  | OtherArch arch -> WUnknown
  | UnknownArch -> WUnknown

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 -> s_ "Linux swap"
  | LinuxRoot (architecture, distro) ->
      string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
  | WindowsRoot -> s_ "Windows root"
  | LinuxBoot -> s_ "Linux /boot"
  | NotRoot -> s_ "Mountable non-root"
  | UnknownNature -> s_ "Unknown partition type"
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"

(* XML helper functions. *)
let rec children_with_name name xml =
  let children = Xml.children xml in
  List.filter (
    function
    | Xml.Element (n, _, _) when n = name -> true
    | _ -> false
  ) children
and xml_has_pcdata_child name pcdata xml =
  xml_has_child_matching (
    function
    | Xml.Element (n, _, [Xml.PCData pcd])
        when n = name && pcd = pcdata -> true
    | _ -> false
  ) xml
and xml_has_attrib_child name attrib xml =
  xml_has_child_matching (
    function
    | Xml.Element (n, attribs, _)
        when n = name && List.mem attrib attribs -> true
    | _ -> false
  ) xml
and xml_has_child_matching f xml =
  let children = Xml.children xml in
  List.exists f children
and find_child_with_name name xml =
  let children = children_with_name name xml in
  match children with
  | [] -> raise Not_found
  | h :: _ -> h
and find_pcdata_child name xml =
  let children = children_with_name name xml in
  let rec loop = function
    | [] -> raise Not_found
    | Xml.Element (_, _, [Xml.PCData pcd]) :: _ -> pcd
    | _ :: tl -> loop tl
  in
  loop children

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 (s_ "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
    (s_ "F12 for next screen | [ALT] [F2] root / no password for shell")

let ok_button = "  OK  "

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

(* Fail and exit with error. *)
let failwith text =
  prerr_endline text;
  let text = "\n"
    ^ text
    ^ s_ "\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 (s_ "Error") text;
  exit 1

(* Display a dialog with checkboxes, return the multiple selected items. *)
let select_multiple ?stage ?(force_one = false) width title items =
  with_newt (
    fun () ->
      open_centered_window ?stage width 20 title;

      let entries =
        List.mapi (
          fun i (label, handle, selected) ->
            let cb =
              Newt.checkbox 1 (i+1) label
                (if selected then '*' else ' ') None in
            (handle, cb)
        ) items in

      let ok = Newt.button 48 16 ok_button in

      let vb =
        if List.length entries > 10 then
          Some (Newt.vertical_scrollbar 58 1 10
                  Newt_int.NEWT_COLORSET_WINDOW
                  Newt_int.NEWT_COLORSET_ACTCHECKBOX)
        else
          None in
      let form = Newt.form vb None [] in
      Newt.form_add_components form (List.map snd entries);
      Newt.form_add_component form ok;

      let selected =
        let rec loop () =
          ignore (Newt.run_form form);
          let selected = List.filter_map (
            fun (handle, cb) ->
              if Newt.checkbox_get_value cb = '*' then Some handle else None
          ) entries in
          if force_one && selected = [] then loop ()
          else selected
        in
        loop () in

      Newt.pop_window ();

      selected
  )

(* Display a dialog with radio buttons, return the single selected item. *)
let select_single ?stage width title items =
  if items = [] then failwith "select_single: no items";

  with_newt (
    fun () ->
      open_centered_window ?stage width 20 title;

      let prev = ref None in
      let entries =
        List.mapi (
          fun i (label, handle) ->
            let rb = Newt.radio_button 1 (i+1) label (!prev = None) !prev in
            prev := Some rb;
            (handle, rb)
        ) items in

      let ok = Newt.button (width-12) 16 ok_button 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

(* 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 (f_ "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 (f_ "shget: command killed by signal %d") i)
  | WSTOPPED i ->
      failwith (sprintf (f_ "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 ()

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

  fun () ->
    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: " ^ s_ "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 (f_ "Disk 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/
   * (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 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 (
    print_endline (s_ "\n\nDid automatic network configuration work?\nHint: If not sure, there is a shell on console [ALT] [F2]");
    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

(* 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 (f_ "ssh: exited with error code %d") i)
  | WSIGNALED i -> failwith (sprintf (f_ "ssh: killed by signal %d") i)
  | WSTOPPED i -> failwith (sprintf (f_ "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 =
  print_endline
    (s_ "Testing SSH connection by listing files in remote directory ...\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 (
    print_endline (s_ "\n\nDid SSH work?\nHint: 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 () =
  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
  );

  (* Choose language early, so messages are translated. *)
  if !config_greeting && List.length supported_langs > 1 then (
    with_newt (
      fun () ->
        let lang = select_single ~stage:(s_ "Select language") 40
          (s_ "Select language")
          supported_langs in

        putenv "LANG" lang;
        ignore (GettextStubCompat.setlocale GettextStubCompat.LC_ALL lang)
    )
  );

  let () = printf (f_ "%s starting up ...\n%!") program_name in

  (* 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
      (s_ "You should only run this script from the live CD or a USB key.");

  (* Start of the information gathering phase. *)
  print_endline
    (s_ "Detecting hard drives (this may take some time) ...");

  (* 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" and size in bytes.
   *)
  let all_block_devices : (string * int64) 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
        (s_ "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

  (* Run blockdev --getsize64 on each partition to get its size.
   *
   * Returns a list of partitions and their size in bytes.
   *)
  let all_partitions : (partition * int64) list =
    List.filter_map (
      fun part ->
        let cmd = "blockdev --getsize64 " ^ quote (dev_of_partition part) in
        let lines = shget cmd in
        match lines with
        | Some (blksize::_) -> Some (part, Int64.of_string blksize)
        | Some [] | None -> None
    ) all_partitions in

  (* Try to determine the nature of each partition.
   * Root? Swap? Architecture? etc.
   *)
  let all_partitions : (partition * (int64 * 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, size) ->
        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, (size, nature))
    ) all_partitions
  in

  print_endline (s_ "Finished detecting hard drives.");

  (* 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
      Not_found | Failure "int_of_string" ->
        (* 'dmesg' can't be parsed.  The backup plan is to look
         * at /proc/meminfo.
         *)
        let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
        match mem with
        | Some (mem::_) -> int_of_float (float_of_string mem)

        (* For some reason even /proc/meminfo didn't work.  Just
         * assume 256 MB instead.
         *)
        | _ -> 256 in

  (* Autodetect system # pCPUs. *)
  let system_nr_cpus =
    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 (f_ "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 = [
                s_ "Physical to Virtual (P2V)", P2V;
                s_ "Virtual to Virtual (V2V)", V2V;
              ] in

              select_single ~stage:(s_ "Transfer type") 40
                (s_ "Transfer type")
                items in

        (* Network configuration. *)
        let config_network =
          match !config_network with
          | Some n -> n
          | None ->
              open_centered_window ~stage:(s_ "Network")
                60 20 (s_ "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
                  (s_ "Automatic from:") (not no_auto) None in
              let shell =
                Newt.radio_button 1 6
                  (s_ "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 qemu =
                Newt.radio_button 1 7
                  (s_ "QEMU user network") false (Some shell) in
              let nonet =
                Newt.radio_button 1 8
                  (s_ "Don't configure the network") false (Some qemu) in
              let static =
                Newt.radio_button 1 9
                  (s_ "Static configuration:") false (Some nonet) in

              let label1 = Newt.label 4 10 (s_ "Interface") in
              let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
              let label2 = Newt.label 4 11 (s_ "IP") in
              let entry2 = Newt.entry 16 11 None 16 [] in
              let label3 = Newt.label 4 12 (s_ "Netmask") in
              let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
              let label4 = Newt.label 4 13 (s_ "Gateway") in
              let entry4 = Newt.entry 16 13 None 16 [] in
              let label5 = Newt.label 4 14 (s_ "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_button 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

  (* Try to bring up the network. *)
  (match config_network with
   | Shell ->
       print_endline (s_ "Network configuration.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n");
       shell ()

   | Static (interface, address, netmask, gateway, nameserver) ->
       print_endline (s_ "Trying static network configuration.\n");
       if not (static_network
                 (interface, address, netmask, gateway, nameserver)) then (
         print_endline (s_ "\nAuto-configuration failed.  Starting a shell.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n");
         shell ()
       )

   | Auto rootfs ->
       print_endline
         (s_ "Trying network auto-configuration from root filesystem ...\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 (
         print_endline (s_ "\nAuto-configuration failed.  Starting a shell.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\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 ->
       print_endline (s_ "Trying QEMU network configuration.\n");
       qemu_network ()

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

  (* 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:(s_ "SSH configuration")
              60 20 (s_ "SSH configuration");

            let label1 = Newt.label 1 1 (s_ "Remote host") in
            let host = Newt.entry 20 1 None 36 [] in
            let label2 = Newt.label 1 2 (s_ "Remote port") in
            let port = Newt.entry 20 2 (Some "22") 6 [] in
            let label3 = Newt.label 1 3 (s_ "Remote directory") in
            let dir = Newt.entry 20 3 (Some "/var/lib/xen/images") 36 [] in
            let label4 = Newt.label 1 4 (s_ "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 (s_ "SSH password") in
            let pass = Newt.entry 20 5 None 16 [Newt.PASSWORD] in
            *)

            let compr =
              Newt.checkbox 16 7 (s_ "Use SSH compression (not good for LANs)")
                ' ' None in

            let check =
              Newt.checkbox 16 9 (s_ "Test SSH connection") '*' None in

            let ok = Newt.button 48 16 ok_button 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

            Newt.pop_window ();
            c
    ) in

  (* If asked, check the SSH connection. *)
  if config_ssh.ssh_check then
    if not (test_ssh config_ssh) then
      failwith (s_ "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:(s_ "Block devices")
                ~force_one:true 60
                (s_ "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:(s_ "Root filesystem") 60
                (s_ "Select root filesystem")
                items in

        let config_target =
          match !config_target with
          | Some t -> t
          | None ->
              open_centered_window ~stage:(s_ "Target system") 40 20
                (s_ "Configure target system");

              let hvlabel = Newt.label 1 1 (s_ "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 (s_ "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 (s_ "Memory (MB):") in
              let mementry = Newt.entry 16 9
                (Some (string_of_int system_memory)) 8 [] in
              let cpulabel = Newt.label 1 10 (s_ "CPUs:") in
              let cpuentry = Newt.entry 16 10
                (Some (string_of_int system_nr_cpus)) 4 [] in
              let maclabel = Newt.label 1 11 (s_ "MAC addr:") in
              let macentry = Newt.entry 16 11 None 20 [] in
              let maclabel2 =
                Newt.label 1 12 (s_ "(leave MAC blank for random)") in

              let libvirtd =
                Newt.checkbox 12 14 (s_ "Use remote libvirtd") '*' None in

              let ok = Newt.button 28 16 ok_button 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

  (* 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
        let arch =
          match arch with
          | Some (arch :: _) -> architecture_of_string arch
          | _ -> I386 (* probably wrong XXX *) in
        { config_target with tgt_architecture = arch }
    | _ -> config_target in

  (* Try to get the capabilities from the remote machine.  If we fail
   * it doesn't matter too much.
   *)
  let caps_os_type, caps_emulator, caps_loader, caps_machine =
    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 "capabilities URI = %S\n%!" name;

      print_endline (s_ "Try to fetch remote hypervisor capabilities ...\n");

      let conn = Libvirt.Connect.connect_readonly ~name () in
      let caps = Libvirt.Connect.get_capabilities conn in
      Libvirt.Connect.close conn;

      (* Turn it into XML data. *)
      let caps = Xml.parse_string caps in
      eprintf "capabilities:\n%s\n%!" (Xml.to_string_fmt caps);

      (* We're looking for a guest with <os_type>hvm</os_type>
       * and <arch name="target-arch">...  Later when we can
       * install PV drivers automatically, we will want to look
       * for paravirt guest types too.
       *)
      let guests = children_with_name "guest" caps in
      let guests =
        List.filter (xml_has_pcdata_child "os_type" "hvm") guests in
      let arch_str = string_of_architecture config_target.tgt_architecture in
      let guests =
        List.filter (
          xml_has_child_matching (
            function
            | Xml.Element (n, attribs, _)
                when n = "arch"
                  && List.exists (
                    fun (n, a) ->
                      n = "name" &&
                      (* deal with i386 vs i686 pestilence *)
                      architecture_of_string a = config_target.tgt_architecture
                  ) attribs
                  -> true
            | _ -> false
          )
        ) guests in

      (* In theory at this point we only have a single guest type
       * remaining.  It might be that we have _zero_ available
       * guest types, which indicates probably an unsupported
       * capability of the remote hypervisor (or just that one of
       * many parsing or heuristics failed).  It might be that
       * we have > 1 available guest types, which indicates some
       * feature we don't know about.
       *)
      let len = List.length guests in
      if len = 0 then (
        message_box (s_ "Warning")
          (sprintf (f_ "Remote hypervisor claims not to support fully virtualized %s guests.\n\nContinuing anyway.\n\n%!") arch_str);
        raise Not_found
      );

      if len > 1 then (
        message_box (s_ "Note")
          (sprintf (f_ "Remote hypervisor supports multiple types of fully virtualized %s guests.\n\nPlease help further development of libvirt and virt-p2v by sending the file /tmp/virt-p2v.log back to the developers.  See the main virt-p2v website for contact details.") arch_str)
      );

      let guest = List.hd guests in

      let os_type =
        try Some (find_pcdata_child "os_type" guest)
        with Not_found -> None in
      let arch_section = find_child_with_name "arch" guest in
      let emulator =
        try Some (find_pcdata_child "emulator" arch_section)
        with Not_found -> None in
      let loader =
        try Some (find_pcdata_child "loader" arch_section)
        with Not_found -> None in
      let machine =
        try Some (find_pcdata_child "machine" arch_section)
        with Not_found -> None in

      os_type, emulator, loader, machine
    with
    | Not_found -> None, None, None, None
    | Xml.Error err ->
        eprintf "XML error: %s\n%!" (Xml.error err);
        None, None, None, None
    | Xml.Not_element _ | Xml.Not_pcdata _ | Xml.No_attribute _ ->
        (* If these occur, need to add some more debugging. *)
        eprintf "XML error when parsing capabilities\n%!";
        None, None, None, None
    | Libvirt.Virterror err ->
        eprintf "libvirt error: %s\n%!" (Libvirt.Virterror.to_string err);
        None, None, None, None
    | Invalid_argument str ->
        eprintf "libvirt error: %s\n%!" str;
        None, None, None, 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;

  print_endline (s_ "Performing LVM snapshots ...\n");

  (* 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 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)
    ) config_devices_to_send in

  (* Run kpartx on the snapshots. *)
  List.iter (
    fun (origin, snapshot) ->
      shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
  ) config_devices_to_send;

  (* Rescan for LVs. *)
  sh "vgscan";
  sh "vgchange -a y";

  (* Mount the root filesystem under /mnt/root. *)
  (match config_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 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)
  ) config_devices_to_send in

  (* Modify files on the root filesystem. *)
  rewrite_fstab ();
  (* XXX Other files to rewrite? *)

  (* Unmount the root filesystem and sync disks. *)
  sh "umount /mnt/root";
  sh "sync";                            (* Ugh, should be in stdlib. *)

  (* 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 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)
  ) 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
   * always get well-formed XML.
   *
   * 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 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

    let arch_str =
      string_of_architecture config_target.tgt_architecture in
    let arch_wordsize =
      wordsize_of_architecture config_target.tgt_architecture in

    (* Standard stuff for every domain. *)
    let name = leaf "name" hostname in
    let uuid = leaf "uuid" (random_uuid ()) in
    let maxmem, memory =
      let m = string_of_int (config_target.tgt_memory * 1024) in
      leaf "maxmem" m, leaf "memory" 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 =
      (* Use capabilities for os_type, etc. else use some good guesses. *)
      let os_type = Option.default "hvm" caps_os_type in
      let machine = Option.default "pc" caps_machine in
      let loader = Option.default "/usr/lib/xen/boot/hvmloader" caps_loader in

      match config_target.tgt_hypervisor with
      | Some Xen ->
          [Xml.Element ("os", [],
                        [leaf "type" os_type;
                         leaf "loader" loader;
                         tleaf "boot" ["dev", "hd"]]);
           Xml.Element ("features", [],
                        [tleaf "pae" [];
                         tleaf "acpi" [];
                         tleaf "apic" []]);
           tleaf "clock" ["sync", "localtime"]]
      | Some KVM ->
          [Xml.Element ("os", [], [leaf "type" os_type]);
           tleaf "clock" ["sync", "localtime"]]
      | Some QEMU ->
          [Xml.Element ("os", [],
                        [Xml.Element ("type",
                                      ["arch", arch_str;
                                       "machine", machine],
                                      [Xml.PCData os_type]);
                         tleaf "boot" ["dev", "hd"]])]
      | None ->
          [] in

    (* <devices> section. *)
    let devices =
      let emulator =
        match caps_emulator with
        (* Use the emulator from the libvirt capabilities. *)
        | Some s -> [leaf "emulator" s]
        | None ->
            (* If we don't have libvirt capabilities, best guess. *)
            match config_target.tgt_hypervisor with
            | Some Xen ->
                [leaf "emulator"
                   (if arch_wordsize = W64 then "/usr/lib64/xen/bin/qemu-dm"
                    else "/usr/lib/xen/bin/qemu-dm")]
            | 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",
                                   config_target.tgt_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",
                             config_ssh.ssh_directory ^ "/" ^ remote_name];
             tleaf "target" ["dev", remote_dev]]
          )
      ) config_devices_to_send in

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

    (* Put it all together in <domain type='foo'>. *)
    Xml.Element (
      "domain",
      (match config_target.tgt_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 config_target.tgt_hypervisor with
      | Some Xen | None -> ""
      | Some QEMU | Some KVM -> " -c qemu:///system" in
    let xml = sprintf (f_ "\
<!--
  This is an automatically generated libvirt configuration file.
  It was written by the %s program.

  Please check the values in this configuration file carefully,
  particularly maxmem, memory, vcpu and any paths.

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

    let xml_len = String.length xml in
    eprintf "length of configuration file is %d bytes\n%!" xml_len;

    print_endline (s_ "\nWriting configuration file ...\n");

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

      let () =
        printf (f_ "\nSending /dev/%s (%.3f GB) to remote machine\n\n%!")
          origin_dev ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in

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

      (* Now connect. *)
      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 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 (f_ " (about %.0f minutes remaining)")
                    (secs_remaining/.60.)
                else
                  printf (f_ " (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. *)
      ssh_finish_upload conn
  ) config_devices_to_send;

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

  (* Clean up and reboot. *)
  ignore (
    message_box (sprintf (f_ "%s has finished") program_name)
      (sprintf (f_ "\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.")
         config_ssh.ssh_directory conf_filename)
  );

  shfailok "eject";
  shfailok "reboot";

  exit 0

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

let usage () =
  let () = eprintf (f_ "usage: virt-p2v [--test] [ttyname]\n%!") in
  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 *)