#!/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
 *)

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

  (* These are now documented in the man page virt-p2v(1).
   * 'None' means ask the user.
   * After changing them, run './virt-p2v --test' to check syntax.
   *)
  remote_host = None;
  remote_port = None;
  remote_directory = None;
  remote_username = None;
  devices_to_send = None;
  root_filesystem = None;
  network = None;
  hypervisor = None;
  architecture = None;
  memory = None;
  vcpus = None;
  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 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 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 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 [--test] [ttyname]\n%!";
  exit 2

(* Make sure that exceptions from 'main' get printed out on stdout
 * as well as stderr, since stderr is probably redirected to the
 * logfile, and so not visible to the user.
 *)
let handle_exn f arg =
  try f arg
  with exn -> print_endline (Printexc.to_string exn); raise exn

(* Test harness for the Makefile.  The Makefile invokes this script as
 * 'virt-p2v --test' just to check it compiles.  When it is running
 * from the actual live CD, there is a single parameter which is the
 * tty name (so usually 'virt-p2v tty1').
 *)
let () =
  match Array.to_list Sys.argv with
  | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
  | [ _; "--test" ] -> ()	        (* Makefile test - do nothing. *)
  | [ _; ttyname ] ->			(* Run main with ttyname. *)
      handle_exn main (Some ttyname)
  | [ _ ] ->			        (* Interactive - no ttyname. *)
      handle_exn main None
  | _ -> usage ()

(* This file must end with a newline *)