#load stuff lower down the file.

[virt-p2v.git] / virt-p2v.ml

#!/usr/bin/ocamlrun /usr/bin/ocaml
(* virt-p2v.ml 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
 *)

#load "unix.cma";;
#directory "+extlib";;
#load "extLib.cma";;
#directory "+pcre";;
#load "pcre.cma";;
#directory "+xml-light";;
#load "xml-light.cma";;

open Unix
open Printf
open ExtList
open ExtString

type state = { greeting : bool;
               remote_host : string option; remote_port : string option;
               remote_directory : string option;
               remote_username : string option;
               network : network option;
               devices_to_send : string list option;
               root_filesystem : partition option;
               hypervisor : hypervisor option;
               architecture : architecture option;
               memory : int option; vcpus : int option;
               mac_address : string option;
             }
and network = Auto | Shell
and partition = Part of string * string (* eg. "hda", "1" *)
              | LV of string * string   (* eg. "VolGroup00", "LogVol00" *)
and hypervisor = Xen | QEMU | KVM
and architecture = I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
                 | OtherArch of string | UnknownArch

(*----------------------------------------------------------------------*)
(* 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.
 *)
let defaults = {
  (* If greeting is true, wait for keypress after boot and during
   * final verification.  Set to 'false' for less interactions.
   *)
  greeting = true;

  (* Remote host and port.  Set to 'Some "host"' and 'Some "port"',
   * else ask the user.
   *)
  remote_host = None;
  remote_port = None;

  (* Remote directory.  Set to 'Some "path"' to set up a
   * directory path, else ask the user.
   *)
  remote_directory = None;

  (* Remote username for ssh.  Set to 'Some "username"', or None to
   * ask the user.
   *)
  remote_username = None;

  (* List of devices to send.  Set to 'Some ["sda"; "sdb"]' for
   * example to select /dev/sda and /dev/sdb.
   *)
  devices_to_send = None;

  (* The root filesystem containing /etc/fstab.  Set to
   * 'Some (Part ("sda", "3"))' or 'Some (LV ("VolGroup00", "LogVol00"))'
   * for example, else ask user.
   *)
  root_filesystem = None;

  (* Network configuration: Set to 'Some Auto' (try to set it up
   * automatically, or 'Some Shell' (give the user a shell).
   *)
  network = None;

  (* Hypervisor: Set to 'Some Xen', 'Some QEMU' or 'Some KVM'. *)
  hypervisor = None;

  (* Architecture: Set to 'Some X86_64' (or another architecture).
   * If set to 'Some UnknownArch' then we try to autodetect the
   * right architecture.
   *)
  architecture = None;

  (* Memory: Set to 'Some nn' with nn in megabytes.  If set to 'Some 0'
   * then we use same amount of RAM as installed in the physical machine.
   *)
  memory = None;

  (* Virtual CPUs: Set to 'Some nn' where nn is the number of virtual CPUs.
   * If set to 'Some 0' then we use the same as physical CPUs in the
   * physical machine.
   *)
  vcpus = None;

  (* MAC address: Set to 'Some "aa:bb:cc:dd:ee:ff"' where the string is
   * the MAC address of the emulated network card.  Set to 'Some ""' to
   * choose a random MAC address.
   *)
  mac_address = None;
}
(* END OF CUSTOM virt-p2v SCRIPT SECTION.                               *)
(*----------------------------------------------------------------------*)

(* 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 dialog_status = Yes of string list | No | Help | Back | Error

type ask_result = Next of state | Prev | Ask_again

type nature = LinuxSwap
            | LinuxRoot of architecture * linux_distro
            | WindowsRoot               (* Windows C: *)
            | 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"

(* Dialog functions.
 *
 * Each function takes some common parameters (eg. ~title) and some
 * dialog-specific parameters.
 *
 * Returns the exit status (Yes lines | No | Help | Back | Error).
 *)
let msgbox, yesno, inputbox, radiolist, checklist =
  (* Internal function to actually run the "dialog" shell command. *)
  let run_dialog cparams params =
    let params = cparams @ params in
    eprintf "dialog %s\n%!"
      (String.concat " " (List.map (sprintf "%S") params));

    (* 'dialog' writes its output/result to stderr, so we need to take
     * special steps to capture that - in other words, manual pipe/fork.
     *)
    let rfd, wfd = pipe () in
    match fork () with
    | 0 ->                              (* child, runs dialog *)
        close rfd;
        dup2 wfd stderr;                (* capture stderr to pipe *)
        execvp "dialog" (Array.of_list ("dialog" :: params))
    | pid ->                            (* parent *)
        close wfd;
        let chan = in_channel_of_descr rfd in
        let result = input_all_lines chan in
        close rfd;
        eprintf "dialog result: %S\n%!" (String.concat "\n" result);
        match snd (wait ()) with
        | WEXITED 0 -> Yes result       (* something selected / entered *)
        | WEXITED 1 -> No               (* cancel / no button *)
        | WEXITED 2 -> Help             (* help pressed *)
        | WEXITED 3 -> Back             (* back button *)
        | WEXITED _ -> Error            (* error or Esc *)
        | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
        | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
  in

  (* Handle the common parameters.  Note Continuation Passing Style. *)
  let with_common cont ?(cancel=false) ?(backbutton=true) title =
    let params = ["--title"; title] in
    let params = if not cancel then "--nocancel" :: params else params in
    let params =
      if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
      else params in
    cont params
  in

  (* Message box and yes/no box. *)
  let rec msgbox =
    with_common (
      fun cparams text height width ->
        run_dialog cparams
          [ "--msgbox"; text; string_of_int height; string_of_int width ]
    )
  and yesno =
    with_common (
      fun cparams text height width ->
        run_dialog cparams
          [ "--yesno"; text; string_of_int height; string_of_int width ]
    )

  (* Simple input box. *)
  and inputbox =
    with_common (
      fun cparams text height width default ->
        run_dialog cparams
          [ "--inputbox"; text; string_of_int height; string_of_int width;
            default ]
    )

  (* Radio list and check list. *)
  and radiolist =
    with_common (
      fun cparams text height width listheight items ->
        let items = List.map (
          function
          | tag, item, true -> [ tag; item; "on" ]
          | tag, item, false -> [ tag; item; "off" ]
        ) items in
        let items = List.concat items in
        let items = "--single-quoted" ::
          "--radiolist" :: text ::
          string_of_int height :: string_of_int width ::
          string_of_int listheight :: items in
        run_dialog cparams items
    )
  and checklist =
    with_common (
      fun cparams text height width listheight items ->
        let items = List.map (
          function
          | tag, item, true -> [ tag; item; "on" ]
          | tag, item, false -> [ tag; item; "off" ]
        ) items in
        let items = List.concat items in
        let items = "--separate-output" ::
          "--checklist" :: text ::
          string_of_int height :: string_of_int width ::
          string_of_int listheight :: items in
        run_dialog cparams items
    )
  in
  msgbox, yesno, inputbox, radiolist, checklist

(* Print failure dialog and exit. *)
let fail_dialog text =
  let text = "\n" ^ text ^ "\n\nIf you want to report this error, there is a shell on [ALT] [F2], log in as root with no password.\n\nPlease provide the contents of /tmp/virt-p2v.log and output of the 'dmesg' command." in
  ignore (msgbox "Error" text 17 50);
  exit 1

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

(* Useful regular expression. *)
let whitespace = Pcre.regexp "[ \t]+"

(* 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 ~rex:whitespace) 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 ->
          fail_dialog (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 state =
  (* Fedora gives an error if this file doesn't exist. *)
  sh "touch /etc/resolv.conf";

(*
  (* We can run /mnt/root/etc/init.d/network in a chroot environment,
   * however this won't work directly because the architecture of the
   * binaries under /mnt/root (eg. /mnt/root/sbin/ip) might not match
   * the architecture of the live CD kernel.  In particular, a 32 bit
   * live CD cannot run 64 bit binaries.  So we also have to bind-mount
   * the live CD's /bin, /sbin, /lib etc. over the equivalents in
   * /mnt/root.
   *)
  let bind dir =
    if is_dir dir = Some true then
      sh ("mount -o bind " ^ quote dir ^ " " ^ quote ("/mnt/root" ^ dir))
  in
  let unbind dir =
    if is_dir dir = Some true then sh ("umount -l " ^ quote ("/mnt/root" ^ dir))
  in
  let dirs = [
    "/bin"; "/sbin"; "/lib"; "/lib64";
    "/usr/bin"; "/usr/sbin"; "/usr/lib"; "/usr/lib64";
    "/proc"; "/sys"
  ] in
  List.iter bind dirs;
  let status = shwithstatus "chroot /mnt/root /etc/init.d/network start" in
  List.iter unbind dirs;
*)

  (* Simpler way to do the above.
   * NB. Lazy unmount is required because dhclient keeps its current
   * 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 remote host to see if this worked. *)
  shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);

  if state.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

(* 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 ~rex:whitespace) 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)
    ) lines;
    close_out chan
  )

(* Main entry point. *)
let rec main ttyname =
  (* 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 "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
    (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 "virt-p2v.ml starting up ...\n%!";

  (* Disable screen blanking on tty. *)
  sh "setterm -blank 0";

  (* Check that the environment is a sane-looking live CD.  If not, bail. *)
  if is_dir "/mnt/root" <> Some true then
    fail_dialog
      "You should only run this script from the live CD or a USB key.";

  printf "virt-p2v.ml detecting hard drives (this may take some time) ...\n%!";

  (* Search for all non-removable block devices.  Do this early and bail
   * if we can't find anything.  This is a list of strings, like "hda".
   *)
  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
      fail_dialog "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 "virt-p2v.ml finished detecting hard drives\n%!";

  (* Dialogs. *)
  let ask_greeting state =
    ignore (msgbox "virt-p2v" "\nWelcome to virt-p2v, a live CD for migrating a physical machine to a virtualized host.\n\nTo continue press the Return key.\n\nTo get a shell you can use [ALT] [F2] and log in as root with no password.\n\nExtra information is logged in /tmp/virt-p2v.log but this file disappears when the machine reboots." 18 50);
    Next state
  in

  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_network state =
    match
    radiolist "Network configuration" "Network configuration" 10 50 2 [
      "auto", "Automatic configuration", state.network = Some Auto;
      "sh", "Configure from the shell", state.network = Some Shell;
    ]
    with
    | Yes ("auto"::_) -> Next { state with network = Some Auto }
    | Yes ("sh"::_) -> Next { state with network = Some Shell }
    | Yes _ | 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_verify state =
    match
    yesno "Verify and proceed"
      (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.

Host:port:    %s : %s
Directory:    %s
Network:      %s
Send devices: %s
Root (/) dev: %s
Hypervisor:   %s
Architecture: %s
Memory:       %s
VCPUs:        %s
MAC address:  %s"
         (Option.default "" state.remote_host)
         (Option.default "" state.remote_port)
         (Option.default "" state.remote_directory)
         (match state.network with
          | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
          | None -> "")
         (String.concat "," (Option.default [] state.devices_to_send))
         (Option.map_default dev_of_partition "" state.root_filesystem)
         (match state.hypervisor with
          | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
          | None -> "Other / not set")
         (match state.architecture with
          | Some UnknownArch -> "Auto-detect"
          | Some arch -> string_of_architecture arch | None -> "")
         (match state.memory with
          | Some 0 -> "Same as physical"
          | Some mem -> string_of_int mem ^ " MB" | None -> "")
         (match state.vcpus with
          | Some 0 -> "Same as physical"
          | Some vcpus -> string_of_int vcpus | None -> "")
         (match state.mac_address with
          | Some "" -> "Random" | Some mac -> mac | None -> "")
      )
      21 50
    with
    | Yes _ -> Next state
    | Back -> Prev
    | No | Help | Error -> Ask_again
  in

  (* This is the list of dialogs, in order.  The user can go forwards or
   * backwards through them.  The second parameter in each pair is
   * false if we need to skip this dialog (info already supplied in
   * 'defaults' above).
   *)
  let dlgs = [|
    ask_greeting,                       (* Initial greeting. *)
      defaults.greeting;
    ask_hostname,                       (* Hostname. *)
      defaults.remote_host = None;
    ask_port,                           (* Port number. *)
      defaults.remote_port = None;
    ask_directory,                      (* Remote directory. *)
      defaults.remote_directory = None;
    ask_username,                       (* Remote username. *)
      defaults.remote_username = None;
    ask_network,                        (* Network configuration. *)
      defaults.network = None;
    ask_devices,                        (* Block devices to send. *)
      defaults.devices_to_send = None;
    ask_root,                           (* Root filesystem. *)
      defaults.root_filesystem = None;
    ask_hypervisor,                     (* Hypervisor. *)
      defaults.hypervisor = None;
    ask_architecture,                   (* Architecture. *)
      defaults.architecture = None;
    ask_memory,                         (* Memory. *)
      defaults.memory = None;
    ask_vcpus,                          (* VCPUs. *)
      defaults.vcpus = None;
    ask_mac_address,                    (* MAC address. *)
      defaults.mac_address = None;
    ask_verify,                         (* Verify settings. *)
      defaults.greeting
  |] in

  (* Loop through the dialogs until we reach the end. *)
  let rec loop posn state =
    eprintf "dialog loop: posn = %d\n%!" posn;
    if posn >= Array.length dlgs then state (* Finished all dialogs. *)
    else (
      let dlg, no_skip = dlgs.(posn) in
      let skip = not no_skip in
      if skip then
        (* Skip this dialog and move straight to the next one. *)
        loop (posn+1) state
      else (
        (* Run dialog. *)
        match dlg state with
        | Next new_state -> loop (posn+1) new_state (* Forwards. *)
        | Prev -> loop (posn-1) state       (* Backwards / back button. *)
        | Ask_again -> loop posn state      (* Repeat the question. *)
      )
    )
  in
  let state = loop 0 defaults in

  eprintf "finished dialog loop\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 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")
  );

  (* See if we can do network configuration. *)
  let network = Option.get state.network in
  (match network with
   | Shell ->
       printf "Network configuration.\n\n";
       printf "Please configure the network from this shell.\n\n";
       printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
       shell ()

   | Auto ->
       printf
         "Trying network auto-configuration from root filesystem ...\n\n%!";
       if not (auto_network state) then (
         printf "\nAuto-configuration failed.  Starting a shell.\n\n";
         printf "Please configure the network from this shell.\n\n";
         printf "When you have finished, exit the shell with ^D or exit.\n\n";
         shell ()
       )
  );

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

  (* Autodetect system memory. *)
  let system_memory =
    let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
    match mem with
    | Some (mem::_) -> int_of_float (float_of_string mem)
    | _ -> 256 in

  (* Autodetect system # pCPUs. *)
  let system_nr_cpus =
    let cpus =
      shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
    match cpus with
    | Some (cpus::_) -> int_of_string cpus
    | _ -> 1 in

  let remote_host = Option.get state.remote_host in
  let remote_port = Option.get state.remote_port in
  let remote_directory = Option.get state.remote_directory in
  let remote_username = Option.get state.remote_username in

  (* Functions to connect and disconnect from the remote system. *)
  let do_connect remote_name _ =
    let cmd = sprintf "ssh -C -l %s -p %s %s \"cat > %s/%s\""
      (quote remote_username) (quote remote_port) (quote remote_host)
      (quote remote_directory) (quote remote_name) in
    eprintf "connect: %s\n%!" cmd;
    let chan = open_process_out cmd in
    descr_of_out_channel chan, chan
  in
  let do_disconnect (_, chan) =
    match close_process_out chan with
    | WEXITED 0 -> ()           (* OK *)
    | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
    | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
    | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
  in

  (* 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 ->
        let random =
          List.map (sprintf "%02x") (
            List.map (fun _ -> Random.int 256) [0;0;0]
          ) in
        String.concat ":" ("00"::"16"::"3e"::random)
    | 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 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 :: memory :: 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 bufsize = 1024 * 1024 in
      let buffer = String.create bufsize in
      let start = gettimeofday () in

      let rec copy bytes_sent last_printed_at =
        let n = read fd buffer 0 bufsize in
        if n > 0 then (
          ignore (write sock buffer 0 n);

          let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
          let last_printed_at =
            let now = gettimeofday () in
            (* Print progress once per second. *)
            if now -. last_printed_at > 1. then (
              let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
              let secs_elapsed = now -. start in
              printf "%.0f%%" (100. *. elapsed);
              (* 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%!";
              now
            )
            else last_printed_at in

          copy bytes_sent last_printed_at
        )
      in
      copy 0L start;

      (* Disconnect. *)
      do_disconnect conn
  ) devices_to_send;

  (* Clean up and reboot. *)
  ignore (
    msgbox "virt-p2v completed"
      (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 [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

(* If the ISO image has an attachment then it could be a new version
 * of virt-p2v.ml (this script).  Get the attachment and run it
 * instead.  Useful mainly for testing, in conjunction with the
 * 'make update' target in the virt-p2v Makefile.
 *)
let magic = "ISOATTACHMENT002"
let magiclen = String.length magic  (* = 16 bytes *)
let trailerlen = magiclen + 8 + 8   (* magic + file start + true size *)

let int64_of_string str =
  let i = ref 0L in
  let add offs shift =
    i :=
      Int64.logor
        (Int64.shift_left (Int64.of_int (Char.code str.[offs])) shift) !i
  in
  add 0 56;  add 1 48;  add 2 40;  add 3 32;
  add 4 24;  add 5 16;  add 6 8;   add 7 0;
  !i

let update ttyname =
  let cdrom = "/dev/cdrom" in
  let output = "/tmp/virt-p2v.ml" in

  try
    let fd = openfile cdrom [O_RDONLY] 0 in
    ignore (LargeFile.lseek fd (Int64.of_int ~-trailerlen) SEEK_END);
    let buf = String.create magiclen in
    if read fd buf 0 magiclen <> magiclen || buf <> magic then (
      close fd;
      raise Exit
    );

    (* Read the size. *)
    let buf = String.create 8 in
    if read fd buf 0 8 <> 8 then
      failwith "cannot read attachment offset";
    let offset = int64_of_string buf in
    let buf = String.create 8 in
    if read fd buf 0 8 <> 8 then
      failwith "cannot read attachment size";
    let size = Int64.to_int (int64_of_string buf) in

    (* Seek to beginning of the attachment. *)
    ignore (LargeFile.lseek fd offset SEEK_SET);

    (* Copy out the attachment. *)
    let fd2 = openfile output [O_WRONLY; O_CREAT; O_TRUNC] 0o755 in
    let bufsize = 4 * 1024 in
    let buffer = String.create bufsize in
    let rec copy remaining =
      if remaining > 0 then (
        let n = min remaining bufsize in
        let n = read fd buffer 0 n in
        if n = 0 then failwith "corrupted or partial attachment";
        ignore (write fd2 buffer 0 n);
        copy (remaining - n)
      )
    in
    copy size;
    close fd2;

    close fd;

    (* Run updated virt-p2v script. *)
    execv output [| output; ttyname |]
  with
    Unix_error _ | Exit ->
      (* Some error, or no attachment, so keep running this script. *)
      handle_exn main (Some ttyname)

(* Test harness for the Makefile.  The Makefile invokes this script as
 * 'virt-p2v.ml --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.ml tty1').
 *)
let () =
  match Array.to_list Sys.argv with
  | [ _; "--test" ] -> ()               (* Makefile test - do nothing. *)
  | [ _; "--update"; ttyname ] ->       (* Test for update and run. *)
      update ttyname
  | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
  | [ _; 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 *)