-#!/usr/bin/ocamlrun /usr/bin/ocaml
-#load "unix.cma";;
-#load "str.cma";;
-
-(* virt-p2v.ml is a script which performs a physical to
+(* -*- tuareg -*- *)
+(* virt-p2v is a script which performs a physical to
* virtual conversion of local disks.
*
* Copyright (C) 2007-2008 Red Hat Inc.
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
-open Unix
-open Printf
-
-type state = { greeting : bool;
- remote_host : string option; remote_port : string option;
- remote_transport : transport option;
- remote_directory : string option;
- network : network option;
- devices_to_send : string list option;
- root_filesystem : string option }
-and transport = SSH | TCP
-and network = Auto | Shell
+type partition =
+ | Part of string * string (* eg. "hda", "1" *)
+ | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
+type transfer =
+ | P2V (* physical to virtual *)
+ | V2V (* virtual to virtual *)
+ (*| V2P*) (* virtual to physical - not impl *)
+type network =
+ | Auto of partition (* Automatic network configuration. *)
+ | Shell (* Start a shell. *)
+ | QEMUUserNet (* Assume we're running under qemu. *)
+ | Static of string * string * string * string * string
+ (* interface, address, netmask, gateway, nameserver *)
+ | NoNetwork
+type ssh_config = {
+ ssh_host : string; (* Remote host for SSH. *)
+ ssh_port : string; (* Remote port. *)
+ ssh_directory : string; (* Remote directory. *)
+ ssh_username : string; (* Remote username. *)
+ ssh_compression : bool; (* If true, use SSH compression. *)
+ ssh_check : bool; (* If true, check SSH is working. *)
+}
+type hypervisor =
+ | Xen
+ | QEMU
+ | KVM
+type architecture =
+ | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
+ | OtherArch of string
+ | UnknownArch
+type wordsize =
+ | W32 | W64 | WUnknown
+type target_config = {
+ tgt_hypervisor : hypervisor option; (* Remote hypervisor. *)
+ tgt_architecture : architecture; (* Remote architecture. *)
+ tgt_memory : int; (* Memory (megabytes). *)
+ tgt_vcpus : int; (* Number of virtual CPUs. *)
+ tgt_mac_address : string; (* MAC address. *)
+ tgt_libvirtd : bool; (* True if libvirtd on remote. *)
+}
(*----------------------------------------------------------------------*)
-(* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
+(* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section.
*
* If left as they are, then this will create a generic virt-p2v script
* which asks the user for each question. If you set the defaults here
*
* Note that 'None' means 'no default' (ie. ask the user) whereas
* 'Some foo' means use 'foo' as the answer.
+ *
+ * These are documented in the virt-p2v(1) manual page.
+ *
+ * After changing them, run './virt-p2v --test' to check syntax.
*)
-let defaults = {
- (* If greeting is true, wait for keypress after boot and during
- * final verification. Set to 'false' for less interactions.
- *)
- greeting = true;
- (* Transport: Set to 'Some SSH' or 'Some TCP' to assume SSH or TCP
- * respectively.
- *)
- remote_transport = None;
+(* If greeting is true, wait for keypress after boot and during
+ * final verification. Set to 'false' for less interactions.
+ *)
+let config_greeting = ref true
- (* Remote host and port. Set to 'Some "host"' and 'Some "port"',
- * else ask the user.
- *)
- remote_host = None;
- remote_port = None;
+(* General type of transfer. *)
+let config_transfer_type = ref None
- (* Remote directory (only for SSH transport). Set to 'Some "path"'
- * to set up a directory path, else ask the user.
- *)
- remote_directory = None;
+(* Network configuration. *)
+let config_network = ref None
- (* List of devices to send. Set to 'Some ["sda"; "sdb"]' for
- * example to select /dev/sda and /dev/sdb.
- *)
- devices_to_send = None;
+(* SSH configuration. *)
+let config_ssh = ref None
- (* The root filesystem containing /etc/fstab. Set to 'Some "sda3"'
- * or 'Some "VolGroup00/LogVol00"' for example, else ask user.
- *)
- root_filesystem = None;
+(* What to transfer. *)
+let config_devices_to_send = ref None
+let config_root_filesystem = ref None
- (* Network configuration: Set to 'Some Auto' (try to set it up
- * automatically, or 'Some Shell' (give the user a shell).
- *)
- network = None;
+(* Configuration of the target. *)
+let config_target = ref None
+
+(* The name of the program as displayed in various places. *)
+let program_name = "virt-p2v"
+
+(* If you want to test the dialog stages, set this to true. *)
+let test_dialog_stages = false
-}
(* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
(*----------------------------------------------------------------------*)
-(* String map type. *)
-module StringMap = Map.Make (String)
-
-(* General helper functions. *)
+open Unix
+open Printf
+open ExtList
+open ExtString
-let default d = function None -> d | Some p -> p
+(*----------------------------------------------------------------------*)
+(* Gettext support.
+ *
+ * Use s_ "string" to mark a translatable string, and f_ "string %s"
+ * to mark a format string (eg. for printf). There are other
+ * functions: see ocaml-gettext manual and GNU gettext info.
+ *
+ * Try not to mark strings which always go to the log file (eg.
+ * eprintf messages).
+ *)
-let string_of_state state =
- sprintf
- "greeting: %b remote: %s:%s%s%s network: %s devices: [%s] root: %s"
- state.greeting
- (default "" state.remote_host)
- (default "" state.remote_port)
- (match state.remote_transport with
- | None -> "" | Some SSH -> " (ssh)" | Some TCP -> " (tcp)")
- (match state.remote_directory with
- | None -> "" | Some dir -> " " ^ dir)
- (match state.network with
- | None -> "none" | Some Auto -> "auto" | Some Shell -> "shell")
- (String.concat "; " (default [] state.devices_to_send))
- (default "" state.root_filesystem)
+module P2VGettext = Gettext.Program (
+ struct
+ let textdomain = "virt-p2v"
+ let codeset = None
+ let dir = None
+ let dependencies = []
+ end
+) (GettextStub.Native)
+open P2VGettext
-type dialog_status = Yes of string list | No | Help | Back | Error
+(*----------------------------------------------------------------------*)
+(* General helper functions. *)
-type ask_result = Next of state | Prev | Ask_again
+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
with
End_of_file -> List.rev !lines
+let dev_of_partition = function
+ | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
+ | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
+
+let string_of_architecture = function
+ | I386 -> "i386"
+ | X86_64 -> "x86_64"
+ | IA64 -> "ia64"
+ | PPC -> "ppc"
+ | PPC64 -> "ppc64"
+ | SPARC -> "sparc"
+ | SPARC64 -> "sparc64"
+ | OtherArch arch -> arch
+ | UnknownArch -> ""
+
+let architecture_of_string = function
+ | str when
+ String.length str = 4 &&
+ (str.[0] = 'i' || str.[0] = 'I') &&
+ (str.[1] >= '3' && str.[1] <= '6') &&
+ str.[2] = '8' && str.[3] = '6' -> I386
+ | "x86_64" | "X86_64" | "x86-64" | "X86-64" -> X86_64
+ | "ia64" | "IA64" -> IA64
+ | "ppc" | "PPC" | "ppc32" | "PPC32" -> PPC
+ | "ppc64" | "PPC64" -> PPC64
+ | "sparc" | "SPARC" | "sparc32" | "SPARC32" -> SPARC
+ | "sparc64" | "SPARC64" -> SPARC64
+ | "" -> UnknownArch
+ | str -> OtherArch str
+
+let wordsize_of_architecture = function
+ | I386 -> W32
+ | X86_64 -> W64
+ | IA64 -> W64
+ | PPC -> W32
+ | PPC64 -> W64
+ | SPARC -> W32
+ | SPARC64 -> W64
+ | OtherArch arch -> WUnknown
+ | UnknownArch -> WUnknown
+
+type nature = LinuxSwap
+ | LinuxRoot of architecture * linux_distro
+ | WindowsRoot (* Windows C: *)
+ | LinuxBoot (* Linux /boot *)
+ | NotRoot (* mountable, but not / or /boot *)
+ | UnknownNature
+and linux_distro = RHEL of int * int
+ | Fedora of int
+ | Debian of int * int
+ | OtherLinux
+
+let rec string_of_nature = function
+ | LinuxSwap -> s_ "Linux swap"
+ | LinuxRoot (architecture, distro) ->
+ string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
+ | WindowsRoot -> s_ "Windows root"
+ | LinuxBoot -> s_ "Linux /boot"
+ | NotRoot -> s_ "Mountable non-root"
+ | UnknownNature -> s_ "Unknown partition type"
+and string_of_linux_distro = function
+ | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
+ | Fedora v -> sprintf "Fedora %d" v
+ | Debian (a,b) -> sprintf "Debian %d.%d" a b
+ | OtherLinux -> "Linux"
+
+(* XML helper functions. *)
+let rec children_with_name name xml =
+ let children = Xml.children xml in
+ List.filter (
+ function
+ | Xml.Element (n, _, _) when n = name -> true
+ | _ -> false
+ ) children
+and xml_has_pcdata_child name pcdata xml =
+ xml_has_child_matching (
+ function
+ | Xml.Element (n, _, [Xml.PCData pcd])
+ when n = name && pcd = pcdata -> true
+ | _ -> false
+ ) xml
+and xml_has_attrib_child name attrib xml =
+ xml_has_child_matching (
+ function
+ | Xml.Element (n, attribs, _)
+ when n = name && List.mem attrib attribs -> true
+ | _ -> false
+ ) xml
+and xml_has_child_matching f xml =
+ let children = Xml.children xml in
+ List.exists f children
+and find_child_with_name name xml =
+ let children = children_with_name name xml in
+ match children with
+ | [] -> raise Not_found
+ | h :: _ -> h
+and find_pcdata_child name xml =
+ let children = children_with_name name xml in
+ let rec loop = function
+ | [] -> raise Not_found
+ | Xml.Element (_, _, [Xml.PCData pcd]) :: _ -> pcd
+ | _ :: tl -> loop tl
+ in
+ loop children
+
+type ('a, 'b) either = Either of 'a | Or of 'b
+
+(* We go into and out of newt mode at various stages, but we might
+ * also need to put up a message at any time. This keeps track of
+ * whether we are in newt mode or not.
+ *
+ * General tip: Try to do any complex operations like setting up the
+ * network or probing disks outside newt mode, and try not to throw
+ * exceptions in newt mode.
+ *)
+let in_newt = ref false
+let with_newt f =
+ if !in_newt then f ()
+ else (
+ in_newt := true;
+ let r =
+ try Either (Newt.init_and_finish f)
+ with exn -> Or exn in
+ in_newt := false;
+ match r with Either r -> r | Or exn -> raise exn
+ )
+
+(* Clear the screen, open a new centered window, make sure the background
+ * and help messages are consistent.
+ *)
+let open_centered_window ?stage width height title =
+ if not !in_newt then failwith (s_ "open_centered_window: not in newt mode");
+ Newt.cls ();
+ Newt.centered_window width height title;
+ let root_text =
+ program_name ^ (match stage with
+ | None -> ""
+ | Some stage -> " - " ^ stage) in
+ Newt.draw_root_text 0 0 root_text;
+ Newt.push_help_line
+ (s_ "F12 for next screen | [ALT] [F2] root / no password for shell")
+
+let ok_button = " OK "
+
+(* Some general dialog boxes. *)
+let message_box title text =
+ with_newt (
+ fun () ->
+ open_centered_window 40 20 title;
+
+ let textbox = Newt.textbox 1 1 36 14 [Newt.WRAP; Newt.SCROLL] in
+ Newt.textbox_set_text textbox text;
+ let ok = Newt.button 28 16 ok_button in
+ let form = Newt.form None None [] in
+ Newt.form_add_components form [textbox; ok];
+
+ Newt.component_takes_focus ok true;
+
+ ignore (Newt.run_form form);
+ Newt.pop_window ()
+ )
+
+(* Fail and exit with error. *)
+let failwith text =
+ prerr_endline text;
+ let text = "\n"
+ ^ text
+ ^ s_ "\n\nIf you want to report this error, there is a shell on [ALT] [F2], log in as root with no password.\n\nPlease provide the contents of /tmp/virt-p2v.log and output of the 'dmesg' command." in
+ message_box (s_ "Error") text;
+ exit 1
+
+(* Display a dialog with checkboxes, return the multiple selected items. *)
+let select_multiple ?stage ?(force_one = false) width title items =
+ with_newt (
+ fun () ->
+ open_centered_window ?stage width 20 title;
+
+ let entries =
+ List.mapi (
+ fun i (label, handle, selected) ->
+ let cb =
+ Newt.checkbox 1 (i+1) label
+ (if selected then '*' else ' ') None in
+ (handle, cb)
+ ) items in
+
+ let ok = Newt.button 48 16 ok_button in
+
+ let vb =
+ if List.length entries > 10 then
+ Some (Newt.vertical_scrollbar 58 1 10
+ Newt_int.NEWT_COLORSET_WINDOW
+ Newt_int.NEWT_COLORSET_ACTCHECKBOX)
+ else
+ None in
+ let form = Newt.form vb None [] in
+ Newt.form_add_components form (List.map snd entries);
+ Newt.form_add_component form ok;
+
+ let selected =
+ let rec loop () =
+ ignore (Newt.run_form form);
+ let selected = List.filter_map (
+ fun (handle, cb) ->
+ if Newt.checkbox_get_value cb = '*' then Some handle else None
+ ) entries in
+ if force_one && selected = [] then loop ()
+ else selected
+ in
+ loop () in
+
+ Newt.pop_window ();
+
+ selected
+ )
+
+(* Display a dialog with radio buttons, return the single selected item. *)
+let select_single ?stage width title items =
+ if items = [] then failwith "select_single: no items";
+
+ with_newt (
+ fun () ->
+ open_centered_window ?stage width 20 title;
+
+ let prev = ref None in
+ let entries =
+ List.mapi (
+ fun i (label, handle) ->
+ let rb = Newt.radio_button 1 (i+1) label (!prev = None) !prev in
+ prev := Some rb;
+ (handle, rb)
+ ) items in
+
+ let ok = Newt.button (width-12) 16 ok_button in
+
+ let vb =
+ if List.length entries > 10 then
+ Some (Newt.vertical_scrollbar 58 1 10
+ Newt_int.NEWT_COLORSET_WINDOW
+ Newt_int.NEWT_COLORSET_ACTCHECKBOX)
+ else
+ None in
+ let form = Newt.form vb None [] in
+ Newt.form_add_components form (List.map snd entries);
+ Newt.form_add_component form ok;
+
+ let (selected, _) =
+ let rec loop () =
+ ignore (Newt.run_form form);
+ let r = Option.get !prev in
+ let r = Newt.radio_get_current r in
+ (* Now we compare 'r' to all the 'rb's in the list
+ * to see which one is selected.
+ *)
+ try
+ List.find (fun (_, rb) -> Newt.component_equals r rb) entries
+ with
+ Not_found -> loop ()
+ in
+ loop () in
+
+ Newt.pop_window ();
+
+ selected
+ )
+
+(* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
+let quote = Filename.quote
+
+(* Run a shell command and check it returns 0. *)
+let sh cmd =
+ eprintf "sh: %s\n%!" cmd;
+ if Sys.command cmd <> 0 then
+ failwith (sprintf (f_ "Command failed:\n\n%s") cmd)
+
+let shfailok cmd =
+ eprintf "shfailok: %s\n%!" cmd;
+ ignore (Sys.command cmd)
+
+let shwithstatus cmd =
+ eprintf "shwithstatus: %s\n%!" cmd;
+ Sys.command cmd
+
(* Same as `cmd` in shell. Any error message will be in the logfile. *)
let shget cmd =
+ eprintf "shget: %s\n%!" cmd;
let chan = open_process_in cmd in
let lines = input_all_lines chan in
match close_process_in chan with
| WEXITED 0 -> Some lines (* command succeeded *)
| WEXITED _ -> None (* command failed *)
- | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
- | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
+ | WSIGNALED i ->
+ failwith (sprintf (f_ "shget: command killed by signal %d") i)
+ | WSTOPPED i ->
+ failwith (sprintf (f_ "shget: command stopped by signal %d") i)
+
+(* Start an interactive shell. Need to juggle file descriptors a bit
+ * because bash write PS1 to stderr (currently directed to the logfile).
+ *)
+let shell () =
+ match fork () with
+ | 0 -> (* child, runs bash *)
+ close stderr;
+ dup2 stdout stderr;
+ (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
+ ignore (
+ Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
+ )
+ | _ -> (* parent, waits *)
+ eprintf "waiting for subshell to exit\n%!";
+ ignore (wait ())
+
+(* Some true if is dir/file, Some false if not, None if not found. *)
+let is_dir path =
+ try Some ((stat path).st_kind = S_DIR)
+ with Unix_error (ENOENT, "stat", _) -> None
+let is_file path =
+ try Some ((stat path).st_kind = S_REG)
+ with Unix_error (ENOENT, "stat", _) -> None
+
+(*----------------------------------------------------------------------*)
+(* P2V-specific helper functions. *)
+
+(* Generate a predictable safe name containing only letters, numbers
+ * and underscores. If passed a string with no letters or numbers,
+ * generates "_1", "_2", etc.
+ *)
+let safe_name =
+ let next_anon =
+ let i = ref 0 in
+ fun () -> incr i; "_" ^ string_of_int !i
+ in
+ fun name ->
+ let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
+ let name = String.copy name in
+ let have_safe = ref false in
+ for i = 0 to String.length name - 1 do
+ if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
+ done;
+ if !have_safe then name else next_anon ()
+
+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 whitespace = Str.regexp "[ \t]+" in
- let comma = Str.regexp "," in
- let devname = Str.regexp "^/dev/\\(.+\\)(.+)$" in
+let get_lvs =
+ let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
- match
- shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
- with
- | None -> []
- | Some lines ->
- let lines = List.map (Str.split whitespace) lines in
- List.map (
- function
- | [vg; lv; pvs; lvsize] ->
- let pvs = Str.split comma pvs in
- let pvs = List.map (
- fun pv ->
- if Str.string_match devname pv then
- Str.matched_group 0
- else
- failwith ("lvs: unexpected device name: " ^ pv)
- ) pvs in
- vg ^ "/" ^ lv, pvs, lvsize
- | _ ->
- failwith "lvs: unexpected output"
- ) lines
-
-(* Get the partitions on a block device. eg. "sda" -> ["sda1";"sda2"] *)
+ fun () ->
+ match
+ shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
+ with
+ | None -> []
+ | Some lines ->
+ let lines = List.map Pcre.split lines in
+ List.map (
+ function
+ | [vg; lv; pvs; lvsize]
+ | [_; vg; lv; pvs; lvsize] ->
+ let pvs = String.nsplit pvs "," in
+ let pvs = List.filter_map (
+ fun pv ->
+ try
+ let subs = Pcre.exec ~rex:devname pv in
+ Some (Pcre.get_substring subs 1)
+ with
+ Not_found ->
+ eprintf "lvs: unexpected device name: %s\n%!" pv;
+ None
+ ) pvs in
+ LV (vg, lv), pvs, lvsize
+ | line ->
+ failwith ("lvs: " ^ s_ "unexpected output: " ^
+ String.concat "," line)
+ ) lines
+
+(* Get the partitions on a block device.
+ * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
+ *)
let get_partitions dev =
- let parts = Sys.readdir ("/sys/block/" ^ dev) in
- let parts = List.filter is_dir parts in
- let regexp = Str.regexp ("^" ^ dev) in
- let parts = List.filter (Str.string_match regexp) parts in
+ let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
+ let devdir = "/sys/block/" ^ dev in
+ let parts = Sys.readdir devdir in
+ let parts = Array.to_list parts in
+ let parts = List.filter (
+ fun name -> Some true = is_dir (devdir ^ "/" ^ name)
+ ) parts in
+ let parts = List.filter_map (
+ fun part ->
+ try
+ let subs = Pcre.exec ~rex part in
+ Some (Part (dev, Pcre.get_substring subs 1))
+ with
+ Not_found -> None
+ ) parts in
parts
+(* Generate snapshot device name from device name. *)
+let snapshot_name dev =
+ "snap" ^ (safe_name dev)
+
+(* Perform a device-mapper snapshot with ramdisk overlay. *)
+let snapshot =
+ let next_free_ram_disk =
+ let i = ref 0 in
+ fun () -> incr i; "/dev/ram" ^ string_of_int !i
+ in
+ fun origin_dev snapshot_dev ->
+ let ramdisk = next_free_ram_disk () in
+ let sectors =
+ let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
+ let lines = shget cmd in
+ match lines with
+ | Some (sectors::_) -> Int64.of_string sectors
+ | Some [] | None ->
+ failwith (sprintf (f_ "Disk snapshot failed: unable to read the size in sectors of block device %s") origin_dev) in
+
+ (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
+ sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
+ snapshot_dev sectors origin_dev);
+ (* Create the snapshot. *)
+ sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
+ snapshot_dev sectors snapshot_dev ramdisk)
+
+(* Try to perform automatic network configuration, assuming a Fedora or
+ * RHEL-like root filesystem mounted on /mnt/root.
+ *)
+let auto_network () =
+ (* Fedora gives an error if this file doesn't exist. *)
+ sh "touch /etc/resolv.conf";
+
+ (* NB. Lazy unmount is required because dhclient keeps its current
+ * directory open on /etc/sysconfig/network-scripts/
+ * (Fixed in dhcp >= 4.0.0 but be generous anyway).
+ *)
+ sh "mount -o bind /mnt/root/etc /etc";
+ let status = shwithstatus "/etc/init.d/network start" in
+ sh "umount -l /etc";
+
+ (* Try to ping the default gateway to see if this worked. *)
+ shfailok "ping -c3 `/sbin/ip route list match 0.0.0.0 | head -1 | awk '{print $3}'`";
+
+ if !config_greeting then (
+ print_endline (s_ "\n\nDid automatic network configuration work?\nHint: If not sure, there is a shell on console [ALT] [F2]");
+ printf " (y/n) %!";
+ let line = read_line () in
+ String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
+ )
+ else
+ (* Non-interactive: return the status of /etc/init.d/network start. *)
+ status = 0
+
+(* Configure the network statically. *)
+let static_network (interface, address, netmask, gateway, nameserver) =
+ let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
+ try
+ do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
+ (quote interface) (quote address) (quote netmask));
+ do_cmd_or_exit (sprintf "route add default gw %s %s"
+ (quote gateway) (quote interface));
+ if nameserver <> "" then
+ do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
+ (quote nameserver));
+ true (* succeeded *)
+ with
+ Exit -> false (* failed *)
+
+(* http://fabrice.bellard.free.fr/qemu/qemu-doc.html#SEC30 *)
+let qemu_network () =
+ sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0";
+ sh "route add default gw 10.0.2.2 eth0";
+ sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"
+
+(* Map local device names to remote devices names. At the moment we
+ * just change sd* to hd* (as device names appear under fullvirt). In
+ * future, lots of complex possibilities.
+ *)
+let remote_of_origin_dev =
+ let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
+ let devsd_subst = Pcre.subst "hd$1" in
+ fun dev ->
+ Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
+
+(* Make an SSH connection to the remote machine, execute command.
+ * The connection remains open until you call ssh_disconnect, it
+ * times out or there is some error.
+ *
+ * NB. The command is NOT quoted.
+ *
+ * Returns a pair (file descriptor, channel), both referring to the
+ * same thing. Use whichever is more convenient.
+ *)
+let ssh_connect config cmd =
+ let cmd = sprintf "ssh%s -l %s -p %s %s %s"
+ (if config.ssh_compression then " -C" else "")
+ (quote config.ssh_username) (quote config.ssh_port) (quote config.ssh_host)
+ cmd in
+ eprintf "ssh_connect: %s\n%!" cmd;
+ let chan = open_process_out cmd in
+ descr_of_out_channel chan, chan
+
+let ssh_disconnect (_, chan) =
+ eprintf "ssh_disconnect\n%!";
+ match close_process_out chan with
+ | WEXITED 0 -> () (* OK *)
+ | WEXITED i -> failwith (sprintf (f_ "ssh: exited with error code %d") i)
+ | WSIGNALED i -> failwith (sprintf (f_ "ssh: killed by signal %d") i)
+ | WSTOPPED i -> failwith (sprintf (f_ "ssh: stopped by signal %d") i)
+
+(* Use these functions to upload a file. *)
+let ssh_start_upload config filename =
+ let cmd =
+ sprintf "cat \\> %s/%s" (quote config.ssh_directory) (quote filename) in
+ ssh_connect config cmd
+
+let ssh_finish_upload = ssh_disconnect
+
+(* Test SSH connection. *)
+let test_ssh config =
+ print_endline
+ (s_ "Testing SSH connection by listing files in remote directory ...\n");
+
+ let cmd = sprintf "/bin/ls %s" (quote config.ssh_directory) in
+ let conn = ssh_connect config cmd in
+ ssh_disconnect conn;
+
+ if !config_greeting then (
+ print_endline (s_ "\n\nDid SSH work?\nHint: If not sure, there is a shell on console [ALT] [F2]\n");
+ printf " (y/n) %!";
+ let line = read_line () in
+ String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
+ )
+ else
+ true
+
+(* Rewrite /mnt/root/etc/fstab. *)
+let rewrite_fstab devices_to_send =
+ let filename = "/mnt/root/etc/fstab" in
+ if is_file filename = Some true then (
+ sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
+
+ let chan = open_in filename in
+ let lines = input_all_lines chan in
+ close_in chan;
+ let lines = List.map Pcre.split lines in
+ let lines = List.map (
+ function
+ | dev :: rest when String.starts_with dev "/dev/" ->
+ let dev = String.sub dev 5 (String.length dev - 5) in
+ let dev = remote_of_origin_dev dev in
+ let dev = "/dev/" ^ dev in
+ dev :: rest
+ | line -> line
+ ) lines in
+
+ let chan = open_out filename in
+ List.iter (
+ function
+ | [dev; mountpoint; fstype; options; freq; passno] ->
+ fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
+ dev mountpoint fstype options freq passno
+ | line ->
+ output_string chan (String.concat " " line);
+ output_char chan '\n'
+ ) lines;
+ close_out chan
+ )
+
+(* Generate a random MAC address in the Xen-reserved space. *)
+let random_mac_address () =
+ let random =
+ List.map (sprintf "%02x") (
+ List.map (fun _ -> Random.int 256) [0;0;0]
+ ) in
+ String.concat ":" ("00"::"16"::"3e"::random)
+
+(* Generate a random UUID. *)
+let random_uuid =
+ let hex = "0123456789abcdef" in
+ fun () ->
+ let str = String.create 32 in
+ for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
+ str
+
+(*----------------------------------------------------------------------*)
(* Main entry point. *)
+
+(* The general plan for the main function is to operate in stages:
+ *
+ * Start-up
+ * |
+ * V
+ * Information gathering about the system
+ * | (eg. block devices, number of CPUs, etc.)
+ * V
+ * Greeting and type of transfer question
+ * |
+ * V
+ * Set up the network
+ * | (after this point we have a working network)
+ * V
+ * Set up SSH
+ * | (after this point we have a working SSH connection)
+ * V
+ * Questions about what to transfer (block devs, root fs) <--.
+ * | |
+ * V |
+ * Questions about hypervisor configuration |
+ * | |
+ * V |
+ * Verify information -------- user wants to change info ----/
+ * |
+ * V
+ * Perform transfer
+ *
+ * Prior versions of virt-p2v (the ones which used 'dialog') had support
+ * for a back button so they could go back through dialogs. I removed
+ * this because it was hard to support and not particularly useful.
+ *)
+
let rec main ttyname =
+ Random.self_init ();
+
(* Running from an init script. We don't have much of a
* login environment, so set one up.
*)
(* 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%!"
+ eprintf "%s starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
+ program_name
(tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
(* Connect stdin/stdout to the tty. *)
let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
dup2 fd stdin;
dup2 fd stdout;
- close fd);
+ close fd
+ );
+ let () = printf (f_ "%s starting up ...\n%!") program_name in
+
+ (* Disable screen blanking on tty. *)
+ sh "setterm -blank 0";
+
+ (* Check that the environment is a sane-looking live CD. If not, bail. *)
+ if not test_dialog_stages && is_dir "/mnt/root" <> Some true then
+ failwith
+ (s_ "You should only run this script from the live CD or a USB key.");
+
+ (* Start of the information gathering phase. *)
+ print_endline
+ (s_ "Detecting hard drives (this may take some time) ...");
(* Search for all non-removable block devices. Do this early and bail
- * if we can't find anything.
+ * if we can't find anything. This is a list of strings, like "hda".
*)
- let all_block_devices =
- let regexp = Str.regexp "^[hs]d" in
+ 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 compare devices in
- let devices = List.filter (fun d -> Str.string_match regexp d 0) devices 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 --getsize on each, and reject any where this fails
+ (* Run blockdev --getsize64 on each, and reject any where this fails
* (probably removable devices).
*)
- let devices = List.map (
+ let devices = List.filter_map (
fun d ->
- let cmd = "blockdev --getsize /dev/" ^ Filename.quote d in
+ let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
let lines = shget cmd in
match lines with
- | Some (blksize::_) -> d, Int64.of_string blksize
- | Some [] | None -> d, 0L
+ | Some (blksize::_) -> Some (d, Int64.of_string blksize)
+ | Some [] | None -> None
) devices in
- let devices = List.filter (fun (_, blksize) -> blksize > 0L) 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.";
+ failwith
+ (s_ "No non-removable block devices (hard disks, etc.) could be found on this machine.");
devices in
- (* For each device that we identified above, search for partitions on
- * the device. These are returned as strings like "hda1" or for
- * LVs "VolGroup00/LogVol00". This creates a StringMap of block device
- * name -> list of partitions on the device.
+ (* Search for partitions and LVs (anything that could contain a
+ * filesystem directly). We refer to these generically as
+ * "partitions".
*)
- let partition_map =
- let lvs = get_lvs () in (* Logical volumes. *)
- eprintf "partition_map: LVs: %s\n%!"
- (String.concat "; " (List.map (fun (lvname, _, _) -> lvname));
+ 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
- let all_partitions = List.map get_partitions all_block_devices in
- let all_partitions = List.concat all_partitions in
- eprintf "partition_map: all parts: %s\n%!"
- (String.concat "; " all_partitions);
+ (* 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));
- (* Ignore any partitions which are used as PVs in the first list. *)
- let all_partitions =
+ (* 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));
-in
+ (* 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;
- (* Dialogs. *)
- let ask_greeting state =
- ignore (
- dialog [
- title "virt-p2v" ();
- msgbox "\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." 17 50
- ]
- );
- Next state
- in
+ 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;
- let ask_transport state =
- match
- dialog [
- title "Connection type" ~backbutton:false ();
- radiolist "Connection type" 10 50 2 [
- "ssh", "SSH (secure shell - recommended)",
- state.remote_transport = Some SSH;
- "tcp", "TCP socket",
- state.remote_transport = Some TCP
- ]
- ]
- with
- | Yes ("ssh"::_) -> Next { state with remote_transport = Some SSH }
- | Yes ("tcp"::_) -> Next { state with remote_transport = Some TCP }
- | Yes _ | No | Help | Error -> Ask_again
- | Back -> Prev
- in
+ 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
- let ask_hostname state =
- match
- dialog [
- title "Remote host" ();
- inputbox "Remote host" 10 50 (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
+ (* 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
- let ask_port state =
- match
- dialog [
- title "Remote port" ();
- inputbox "Remote port" 10 50 (default "" state.remote_port)
- ]
- with
- | Yes [] ->
- if state.remote_transport = Some TCP then
- Next { state with remote_port = Some "16211" }
- else
- Next { state with remote_port = Some "22" }
- | Yes (port::_) -> Next { state with remote_port = Some port }
- | No | Help | Error -> Ask_again
- | Back -> Prev
- in
+ List.map (
+ fun part ->
+ let dev = dev_of_partition part in (* Get /dev device. *)
- let ask_directory state =
- match
- dialog [
- title "Remote directory" ();
- inputbox "Remote directory" 10 50 (default "" state.remote_directory)
- ]
- with
- | Yes [] ->
- Next { state with remote_directory = Some "/var/lib/xen/images" }
- | Yes (dir::_) -> Next { state with remote_directory = Some dir }
- | No | Help | Error -> Ask_again
- | Back -> Prev
+ 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
- let ask_network state =
- match
- dialog [
- title "Network configuration" ();
- radiolist "Network configuration" 10 50 2 [
- "auto", "Automatic configuration", state.network = Some Auto;
- "sh", "Configure from the shell", state.network = Some Shell;
- ]
- ]
+ print_endline (s_ "Finished detecting hard drives.");
+
+ (* Autodetect system memory. *)
+ let system_memory =
+ (* Try to parse dmesg first to find the 'Memory:' report when
+ * the kernel booted. If available, this can give us an
+ * indication of usable RAM on this system.
+ *)
+ let dmesg = shget "dmesg" in
+ try
+ let dmesg =
+ match dmesg with Some lines -> lines | None -> raise Not_found in
+ let line =
+ List.find (fun line -> String.starts_with line "Memory: ") dmesg in
+ let subs = Pcre.exec ~pat:"k/([[:digit:]]+)k available" line in
+ let mem = Pcre.get_substring subs 1 in
+ int_of_string mem / 1024
with
- | 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
+ Not_found | Failure "int_of_string" ->
+ (* 'dmesg' can't be parsed. The backup plan is to look
+ * at /proc/meminfo.
+ *)
+ let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
+ match mem with
+ | Some (mem::_) -> int_of_float (float_of_string mem)
- let ask_devices state =
- let selected_devices = default [] state.devices_to_send in
- let devices = List.map (
- fun (dev, blksize) ->
- (dev,
- sprintf "/dev/%s (%g GB)" dev ((Int64.to_float blksize) /. 2_097_152.),
- List.mem dev selected_devices)
- ) all_block_devices in
- match
- dialog [
- title "Devices" ();
- checklist "Pick devices to send" 15 50 8 devices
- ]
+ (* For some reason even /proc/meminfo didn't work. Just
+ * assume 256 MB instead.
+ *)
+ | _ -> 256 in
+
+ (* Autodetect system # pCPUs. *)
+ let system_nr_cpus =
+ let cpus =
+ shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
+ match cpus with
+ | Some (cpus::_) -> int_of_string cpus
+ | _ -> 1 in
+
+ (* Greeting, type of transfer, network question stages.
+ * These are all done in newt mode.
+ *)
+ let config_transfer_type, config_network =
+ with_newt (
+ fun () ->
+ (* Greeting. *)
+ if !config_greeting then
+ message_box program_name (sprintf (f_ "Welcome to %s, a live CD for migrating a physical machine to a virtualized host.\n\nTo continue press the Return key.\n\nTo get a shell you can use [ALT] [F2] and log in as root with no password.\n\nExtra information is logged in /tmp/virt-p2v.log but this file disappears when the machine reboots.") program_name);
+
+ (* Type of transfer. *)
+ let config_transfer_type =
+ match !config_transfer_type with
+ | Some t -> t
+ | None ->
+ let items = [
+ s_ "Physical to Virtual (P2V)", P2V;
+ s_ "Virtual to Virtual (V2V)", V2V;
+ ] in
+
+ select_single ~stage:(s_ "Transfer type") 40
+ (s_ "Transfer type")
+ items in
+
+ (* Network configuration. *)
+ let config_network =
+ match !config_network with
+ | Some n -> n
+ | None ->
+ open_centered_window ~stage:(s_ "Network")
+ 60 20 (s_ "Configure network");
+
+ let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in
+ Newt.listbox_set_width autolist 52;
+
+ (* Populate the "Automatic" listbox with RHEL/Fedora
+ * root partitions found which allow us to do
+ * automatic configuration in a known way.
+ *)
+ let rec loop = function
+ | [] -> ()
+ | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
+ :: parts ->
+ let label =
+ sprintf "%s (%s)"
+ (dev_of_partition partition)
+ (string_of_linux_distro distro) in
+ ignore (Newt.listbox_append_entry autolist label partition);
+ loop parts
+ | _ :: parts -> loop parts
+ in
+ loop all_partitions;
+
+ (* If there is no suitable root partition (the listbox
+ * is empty) then disable the auto option and the listbox.
+ *)
+ let no_auto = Newt.listbox_item_count autolist = 0 in
+
+ let auto =
+ Newt.radio_button 1 1
+ (s_ "Automatic from:") (not no_auto) None in
+ let shell =
+ Newt.radio_button 1 6
+ (s_ "Start a shell") no_auto (Some auto) in
+
+ if no_auto then (
+ Newt.component_takes_focus auto false;
+ Newt.component_takes_focus
+ (Newt.component_of_listbox autolist) false
+ );
+
+ let qemu =
+ Newt.radio_button 1 7
+ (s_ "QEMU user network") false (Some shell) in
+ let nonet =
+ Newt.radio_button 1 8
+ (s_ "Don't configure the network") false (Some qemu) in
+ let static =
+ Newt.radio_button 1 9
+ (s_ "Static configuration:") false (Some nonet) in
+
+ let label1 = Newt.label 4 10 (s_ "Interface") in
+ let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
+ let label2 = Newt.label 4 11 (s_ "IP") in
+ let entry2 = Newt.entry 16 11 None 16 [] in
+ let label3 = Newt.label 4 12 (s_ "Netmask") in
+ let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
+ let label4 = Newt.label 4 13 (s_ "Gateway") in
+ let entry4 = Newt.entry 16 13 None 16 [] in
+ let label5 = Newt.label 4 14 (s_ "Nameserver") in
+ let entry5 = Newt.entry 16 14 None 16 [] in
+
+ let enable_static () =
+ Newt.component_takes_focus entry1 true;
+ Newt.component_takes_focus entry2 true;
+ Newt.component_takes_focus entry3 true;
+ Newt.component_takes_focus entry4 true;
+ Newt.component_takes_focus entry5 true
+ in
+
+ let disable_static () =
+ Newt.component_takes_focus entry1 false;
+ Newt.component_takes_focus entry2 false;
+ Newt.component_takes_focus entry3 false;
+ Newt.component_takes_focus entry4 false;
+ Newt.component_takes_focus entry5 false
+ in
+
+ let enable_autolist () =
+ Newt.component_takes_focus
+ (Newt.component_of_listbox autolist) true
+ in
+ let disable_autolist () =
+ Newt.component_takes_focus
+ (Newt.component_of_listbox autolist) false
+ in
+
+ disable_static ();
+ Newt.component_add_callback auto
+ (fun () ->disable_static (); enable_autolist ());
+ Newt.component_add_callback shell
+ (fun () -> disable_static (); disable_autolist ());
+ Newt.component_add_callback qemu
+ (fun () -> disable_static (); disable_autolist ());
+ Newt.component_add_callback nonet
+ (fun () -> disable_static (); disable_autolist ());
+ Newt.component_add_callback static
+ (fun () -> enable_static (); disable_autolist ());
+
+ let ok = Newt.button 48 16 ok_button in
+
+ let form = Newt.form None None [] in
+ Newt.form_add_components form [auto;
+ Newt.component_of_listbox autolist;
+ shell;qemu;nonet;static;
+ label1;label2;label3;label4;label5;
+ entry1;entry2;entry3;entry4;entry5;
+ ok];
+
+ let n =
+ let rec loop () =
+ ignore (Newt.run_form form);
+
+ let r = Newt.radio_get_current auto in
+ if Newt.component_equals r auto then (
+ match Newt.listbox_get_current autolist with
+ | None -> loop ()
+ | Some part -> Auto part
+ )
+ else if Newt.component_equals r shell then Shell
+ else if Newt.component_equals r qemu then QEMUUserNet
+ else if Newt.component_equals r nonet then NoNetwork
+ else if Newt.component_equals r static then (
+ let interface = Newt.entry_get_value entry1 in
+ let address = Newt.entry_get_value entry2 in
+ let netmask = Newt.entry_get_value entry3 in
+ let gateway = Newt.entry_get_value entry4 in
+ let nameserver = Newt.entry_get_value entry5 in
+ if interface = "" || address = "" ||
+ netmask = "" || gateway = "" then
+ loop ()
+ else
+ Static (interface, address, netmask, gateway, nameserver)
+ )
+ else loop ()
+ in
+ loop () in
+ Newt.pop_window ();
+
+ n in
+
+ config_transfer_type, config_network
+ ) in
+
+ (* Try to bring up the network. *)
+ (match config_network with
+ | Shell ->
+ print_endline (s_ "Network configuration.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n");
+ shell ()
+
+ | Static (interface, address, netmask, gateway, nameserver) ->
+ print_endline (s_ "Trying static network configuration.\n");
+ if not (static_network
+ (interface, address, netmask, gateway, nameserver)) then (
+ print_endline (s_ "\nAuto-configuration failed. Starting a shell.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n");
+ shell ()
+ )
+
+ | Auto rootfs ->
+ print_endline
+ (s_ "Trying network auto-configuration from root filesystem ...\n");
+
+ (* Mount the root filesystem read-only under /mnt/root. *)
+ sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");
+
+ if not (auto_network ()) then (
+ print_endline (s_ "\nAuto-configuration failed. Starting a shell.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n");
+ shell ()
+ );
+
+ (* NB. Lazy unmount is required because dhclient keeps its current
+ * directory open on /etc/sysconfig/network-scripts/
+ *)
+ sh ("umount -l /mnt/root");
+
+ | QEMUUserNet ->
+ print_endline (s_ "Trying QEMU network configuration.\n");
+ qemu_network ()
+
+ | NoNetwork -> (* this is easy ... *) ()
+ );
+
+ (* SSH configuration phase. *)
+ let config_ssh =
+ with_newt (
+ fun () ->
+ match !config_ssh with
+ | Some c -> c
+ | None ->
+ (* Query the user for SSH configuration. *)
+ open_centered_window ~stage:(s_ "SSH configuration")
+ 60 20 (s_ "SSH configuration");
+
+ let label1 = Newt.label 1 1 (s_ "Remote host") in
+ let host = Newt.entry 20 1 None 36 [] in
+ let label2 = Newt.label 1 2 (s_ "Remote port") in
+ let port = Newt.entry 20 2 (Some "22") 6 [] in
+ let label3 = Newt.label 1 3 (s_ "Remote directory") in
+ let dir = Newt.entry 20 3 (Some "/var/lib/xen/images") 36 [] in
+ let label4 = Newt.label 1 4 (s_ "SSH username") in
+ let user = Newt.entry 20 4 (Some "root") 16 [] in
+ (*
+ There's no sensible way to support this for SSH:
+ let label5 = Newt.label 1 5 (s_ "SSH password") in
+ let pass = Newt.entry 20 5 None 16 [Newt.PASSWORD] in
+ *)
+
+ let compr =
+ Newt.checkbox 16 7 (s_ "Use SSH compression (not good for LANs)")
+ ' ' None in
+
+ let check =
+ Newt.checkbox 16 9 (s_ "Test SSH connection") '*' None in
+
+ let ok = Newt.button 48 16 ok_button in
+
+ let form = Newt.form None None [] in
+ Newt.form_add_components form [label1;label2;label3;label4;
+ host;port;dir;user;
+ compr;check;
+ ok];
+
+ let c =
+ let rec loop () =
+ ignore (Newt.run_form form);
+ let host = Newt.entry_get_value host in
+ let port = Newt.entry_get_value port in
+ let dir = Newt.entry_get_value dir in
+ let user = Newt.entry_get_value user in
+ let compr = Newt.checkbox_get_value compr = '*' in
+ let check = Newt.checkbox_get_value check = '*' in
+ if host <> "" && port <> "" && user <> "" then
+ { ssh_host = host; ssh_port = port; ssh_directory = dir;
+ ssh_username = user;
+ ssh_compression = compr;
+ ssh_check = check; }
+ else
+ loop ()
+ in
+ loop () in
+
+ Newt.pop_window ();
+ c
+ ) in
+
+ (* If asked, check the SSH connection. *)
+ if config_ssh.ssh_check then
+ if not (test_ssh config_ssh) then
+ failwith (s_ "SSH configuration failed");
+
+ (* Devices and root partition and target configuration selection stage. *)
+ let config_devices_to_send, config_root_filesystem, config_target =
+ with_newt (
+ fun () ->
+ let config_devices_to_send =
+ match !config_devices_to_send with
+ | Some ds -> ds
+ | None ->
+ let items = List.map (
+ fun (dev, size) ->
+ let label =
+ sprintf "/dev/%s (%.3f GB)" dev
+ ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in
+ (label, dev, true)
+ ) all_block_devices in
+
+ select_multiple ~stage:(s_ "Block devices")
+ ~force_one:true 60
+ (s_ "Select block devices to send")
+ items in
+
+ let config_root_filesystem =
+ match !config_root_filesystem with
+ | Some fs -> fs
+ | None ->
+ let items = List.map (
+ fun (part, nature) ->
+ let label =
+ sprintf "%s %s" (dev_of_partition part)
+ (string_of_nature nature) in
+ (label, part)
+ ) all_partitions in
+
+ select_single ~stage:(s_ "Root filesystem") 60
+ (s_ "Select root filesystem")
+ items in
+
+ let config_target =
+ match !config_target with
+ | Some t -> t
+ | None ->
+ open_centered_window ~stage:(s_ "Target system") 40 20
+ (s_ "Configure target system");
+
+ let hvlabel = Newt.label 1 1 (s_ "Hypervisor:") in
+ let hvlistbox = Newt.listbox 16 1 4 [Newt.SCROLL] in
+ Newt.listbox_append_entry hvlistbox "Xen" (Some Xen);
+ Newt.listbox_append_entry hvlistbox "QEMU" (Some QEMU);
+ Newt.listbox_append_entry hvlistbox "KVM" (Some KVM);
+ Newt.listbox_append_entry hvlistbox "Other" None;
+
+ let archlabel = Newt.label 1 5 (s_ "Architecture:") in
+ let archlistbox = Newt.listbox 16 5 4 [Newt.SCROLL] in
+ Newt.listbox_append_entry archlistbox "i386" I386;
+ Newt.listbox_append_entry archlistbox
+ "x86-64 (64-bit x86)" X86_64;
+ Newt.listbox_append_entry archlistbox "IA64 (Itanium)" IA64;
+ Newt.listbox_append_entry archlistbox "PowerPC 32-bit" PPC;
+ Newt.listbox_append_entry archlistbox "PowerPC 64-bit" PPC64;
+ Newt.listbox_append_entry archlistbox "SPARC 32-bit" SPARC;
+ Newt.listbox_append_entry archlistbox "SPARC 64-bit" SPARC64;
+ Newt.listbox_append_entry archlistbox "Unknown/other" UnknownArch;
+
+ (* Get the architecture of the selected root filesystem.
+ * If not known, default to UnknownArch.
+ *)
+ Newt.listbox_set_current_by_key archlistbox UnknownArch;
+ (try
+ match List.assoc config_root_filesystem all_partitions with
+ | LinuxRoot (arch, _) ->
+ Newt.listbox_set_current_by_key archlistbox arch
+ | _ -> ()
+ with
+ Not_found -> ());
+
+ let memlabel = Newt.label 1 9 (s_ "Memory (MB):") in
+ let mementry = Newt.entry 16 9
+ (Some (string_of_int system_memory)) 8 [] in
+ let cpulabel = Newt.label 1 10 (s_ "CPUs:") in
+ let cpuentry = Newt.entry 16 10
+ (Some (string_of_int system_nr_cpus)) 4 [] in
+ let maclabel = Newt.label 1 11 (s_ "MAC addr:") in
+ let macentry = Newt.entry 16 11 None 20 [] in
+ let maclabel2 =
+ Newt.label 1 12 (s_ "(leave MAC blank for random)") in
+
+ let libvirtd =
+ Newt.checkbox 12 14 (s_ "Use remote libvirtd") '*' None in
+
+ let ok = Newt.button 28 16 ok_button in
+
+ let form = Newt.form None None [] in
+ Newt.form_add_components form
+ [hvlabel; Newt.component_of_listbox hvlistbox;
+ archlabel; Newt.component_of_listbox archlistbox;
+ memlabel; mementry;
+ cpulabel; cpuentry;
+ maclabel; macentry; maclabel2;
+ libvirtd;
+ ok];
+
+ let c =
+ let rec loop () =
+ ignore (Newt.run_form form);
+ try
+ let hv = Newt.listbox_get_current hvlistbox in
+ let arch = Newt.listbox_get_current archlistbox in
+ let mem = int_of_string (Newt.entry_get_value mementry) in
+ let cpus = int_of_string (Newt.entry_get_value cpuentry) in
+ let mac = Newt.entry_get_value macentry in
+ let libvirtd = Newt.checkbox_get_value libvirtd = '*' in
+ if hv <> None && arch <> None && mem >= 0 && cpus >= 0
+ then
+ { tgt_hypervisor = Option.get hv;
+ tgt_architecture = Option.get arch;
+ tgt_memory = mem; tgt_vcpus = cpus;
+ tgt_mac_address =
+ if mac <> "" then mac else random_mac_address ();
+ tgt_libvirtd = libvirtd }
+ else
+ loop ()
+ with
+ Not_found | Failure "int_of_string" -> loop ()
+ in
+ loop () in
+
+ Newt.pop_window ();
+
+ c in
+
+ config_devices_to_send, config_root_filesystem, config_target
+ ) in
+
+ (* If architecture is set to UnknownArch, then assume the same
+ * architecture as the live CD.
+ *)
+ let config_target =
+ match config_target.tgt_architecture with
+ | UnknownArch ->
+ let arch = shget "uname -m" in
+ let arch =
+ match arch with
+ | Some (arch :: _) -> architecture_of_string arch
+ | _ -> I386 (* probably wrong XXX *) in
+ { config_target with tgt_architecture = arch }
+ | _ -> config_target in
+
+ (* Try to get the capabilities from the remote machine. If we fail
+ * it doesn't matter too much.
+ *)
+ let caps_os_type, caps_emulator, caps_loader, caps_machine =
+ try
+ if not config_target.tgt_libvirtd then raise Not_found;
+
+ let proto, path =
+ match config_target.tgt_hypervisor with
+ | Some Xen -> "xen", "/"
+ | Some (QEMU|KVM) -> "qemu", "/system"
+ | None -> raise Not_found in
+ let name =
+ sprintf "%s+ssh://%s@%s:%s%s"
+ proto config_ssh.ssh_username
+ config_ssh.ssh_host config_ssh.ssh_port path in
+ eprintf "capabilities URI = %S\n%!" name;
+
+ print_endline (s_ "Try to fetch remote hypervisor capabilities ...\n");
+
+ let conn = Libvirt.Connect.connect_readonly ~name () in
+ let caps = Libvirt.Connect.get_capabilities conn in
+ Libvirt.Connect.close conn;
+
+ (* Turn it into XML data. *)
+ let caps = Xml.parse_string caps in
+ eprintf "capabilities:\n%s\n%!" (Xml.to_string_fmt caps);
+
+ (* We're looking for a guest with <os_type>hvm</os_type>
+ * and <arch name="target-arch">... Later when we can
+ * install PV drivers automatically, we will want to look
+ * for paravirt guest types too.
+ *)
+ let guests = children_with_name "guest" caps in
+ let guests =
+ List.filter (xml_has_pcdata_child "os_type" "hvm") guests in
+ let arch_str = string_of_architecture config_target.tgt_architecture in
+ let guests =
+ List.filter (
+ xml_has_child_matching (
+ function
+ | Xml.Element (n, attribs, _)
+ when n = "arch"
+ && List.exists (
+ fun (n, a) ->
+ n = "name" &&
+ (* deal with i386 vs i686 pestilence *)
+ architecture_of_string a = config_target.tgt_architecture
+ ) attribs
+ -> true
+ | _ -> false
+ )
+ ) guests in
+
+ (* In theory at this point we only have a single guest type
+ * remaining. It might be that we have _zero_ available
+ * guest types, which indicates probably an unsupported
+ * capability of the remote hypervisor (or just that one of
+ * many parsing or heuristics failed). It might be that
+ * we have > 1 available guest types, which indicates some
+ * feature we don't know about.
+ *)
+ let len = List.length guests in
+ if len = 0 then (
+ message_box (s_ "Warning")
+ (sprintf (f_ "Remote hypervisor claims not to support fully virtualized %s guests.\n\nContinuing anyway.\n\n%!") arch_str);
+ raise Not_found
+ );
+
+ if len > 1 then (
+ message_box (s_ "Note")
+ (sprintf (f_ "Remote hypervisor supports multiple types of fully virtualized %s guests.\n\nPlease help further development of libvirt and virt-p2v by sending the file /tmp/virt-p2v.log back to the developers. See the main virt-p2v website for contact details.") arch_str)
+ );
+
+ let guest = List.hd guests in
+
+ let os_type =
+ try Some (find_pcdata_child "os_type" guest)
+ with Not_found -> None in
+ let arch_section = find_child_with_name "arch" guest in
+ let emulator =
+ try Some (find_pcdata_child "emulator" arch_section)
+ with Not_found -> None in
+ let loader =
+ try Some (find_pcdata_child "loader" arch_section)
+ with Not_found -> None in
+ let machine =
+ try Some (find_pcdata_child "machine" arch_section)
+ with Not_found -> None in
+
+ os_type, emulator, loader, machine
with
- | Yes [] | No | Help | Error -> Ask_again
- | Yes devices -> Next { state with devices_to_send = Some devices }
- | Back -> Prev
- in
+ | Not_found -> None, None, None, None
+ | Xml.Error err ->
+ eprintf "XML error: %s\n%!" (Xml.error err);
+ None, None, None, None
+ | Xml.Not_element _ | Xml.Not_pcdata _ | Xml.No_attribute _ ->
+ (* If these occur, need to add some more debugging. *)
+ eprintf "XML error when parsing capabilities\n%!";
+ None, None, None, None
+ | Libvirt.Virterror err ->
+ eprintf "libvirt error: %s\n%!" (Libvirt.Virterror.to_string err);
+ None, None, None, None
+ | Invalid_argument str ->
+ eprintf "libvirt error: %s\n%!" str;
+ None, None, None, None in
- (* 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).
+ (* In test mode, exit here before we do Bad Things to the developer's
+ * hard disk.
*)
- let dlgs = [|
- ask_greeting, (* Initial greeting. *)
- defaults.greeting;
- ask_transport, (* Transport (ssh, tcp) *)
- defaults.remote_transport = None;
- ask_hostname, (* Hostname. *)
- defaults.remote_host = None;
- ask_port, (* Port number. *)
- defaults.remote_port = None;
- ask_directory, (* Remote directory. *)
- defaults.remote_directory = 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_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
+ if test_dialog_stages then exit 1;
- eprintf "finished dialog loop\nstate = %s\n%!" (string_of_state state);
+ print_endline (s_ "Performing LVM snapshots ...\n");
+ (* Switch LVM config. *)
+ sh "vgchange -a n";
+ putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
+ sh "rm -f /etc/lvm/cache/.cache";
+ sh "rm -f /etc/lvm.new/cache/.cache";
+ (* Snapshot the block devices to send. *)
+ let config_devices_to_send =
+ List.map (
+ fun origin_dev ->
+ let snapshot_dev = snapshot_name origin_dev in
+ snapshot origin_dev snapshot_dev;
+ (origin_dev, snapshot_dev)
+ ) config_devices_to_send in
+ (* Run kpartx on the snapshots. *)
+ List.iter (
+ fun (origin, snapshot) ->
+ shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
+ ) config_devices_to_send;
+ (* Rescan for LVs. *)
+ sh "vgscan";
+ sh "vgchange -a y";
+ (* Mount the root filesystem under /mnt/root. *)
+ (match config_root_filesystem with
+ | Part (dev, partnum) ->
+ let dev = dev ^ partnum in
+ let snapshot_dev = snapshot_name dev in
+ sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
- ()
+ | LV (vg, lv) ->
+ (* The LV will be backed by a snapshot device, so just mount
+ * directly.
+ *)
+ sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
+ );
-(* Run the external 'dialog' command with the given list of parameters.
- * Actually it's a list-of-list-of-parameters because you would normally
- * use this function like this:
- * dialog [
- * title (* title and other common parameters *) ();
- * dialogtype (* specific parameter *)
- * ]
- * where 'dialogtype' is a function such as 'msgbox' (see below)
- * representing a specific subfunction of dialog.
- *
- * The functions 'title' and 'dialogtype' return partially-constructed
- * lists of shell parameters. See the dialog manpage.
- *
- * Returns the exit status (Yes lines | No | Help | Back | Error).
- *)
-and dialog params =
- let params = List.concat params in (* list-of-list to flat list *)
- eprintf "dialog [%s]\n%!"
- (String.concat "; " (List.map (sprintf "%S") params));
+ (* Work out what devices will be called at the remote end. *)
+ let config_devices_to_send = List.map (
+ fun (origin_dev, snapshot_dev) ->
+ let remote_dev = remote_of_origin_dev origin_dev in
+ (origin_dev, snapshot_dev, remote_dev)
+ ) config_devices_to_send in
+
+ (* Modify files on the root filesystem. *)
+ rewrite_fstab config_devices_to_send;
+ (* XXX Other files to rewrite? *)
- (* 'dialog' writes its output/result to stderr, so we need to take
- * special steps to capture that - in other words, manual pipe/fork.
+ (* Unmount the root filesystem and sync disks. *)
+ sh "umount /mnt/root";
+ sh "sync"; (* Ugh, should be in stdlib. *)
+
+ (* XXX This is using the hostname derived from network configuration
+ * above. We might want to ask the user to choose.
*)
- let 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)
-
-(* Title and common dialog options. *)
-and title title ?(cancel=false) ?(backbutton=true) () =
- 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
- params
-
-(* Message box. *)
-and msgbox text height width =
- [ "--msgbox"; text; string_of_int height; string_of_int width ]
-
-(* Simple input box. *)
-and inputbox text height width default =
- [ "--inputbox"; text; string_of_int height; string_of_int width; default ]
-
-(* Radio list and check list. *)
-and radiolist 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
- "--single-quoted" ::
- "--radiolist" :: text :: string_of_int height :: string_of_int width ::
- string_of_int listheight :: items
-
-and checklist 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
- "--separate-output" ::
- "--checklist" :: text :: string_of_int height :: string_of_int width ::
- string_of_int listheight :: items
-
-(* Print failure dialog and exit. *)
-and fail_dialog text =
- let text = 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
+ let hostname = safe_name (gethostname ()) in
+ let basename =
+ let date = sprintf "%04d%02d%02d%02d%02d"
+ (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
+ "p2v-" ^ hostname ^ "-" ^ date in
+
+ (* Work out what the image filenames will be at the remote end. *)
+ let config_devices_to_send = List.map (
+ fun (origin_dev, snapshot_dev, remote_dev) ->
+ let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
+ (origin_dev, snapshot_dev, remote_dev, remote_name)
+ ) config_devices_to_send in
+
+ (* Write a configuration file. Not sure if this is any better than
+ * just 'sprintf-ing' bits of XML text together, but at least we will
+ * always get well-formed XML.
+ *
+ * XXX There is a case for using virt-install to generate this XML.
+ * When we start to incorporate libvirt access & storage API this
+ * needs to be rethought.
+ *)
+ let conf_filename = basename ^ ".conf" in
+
+ let xml =
+ (* Shortcut to make "<name>value</name>". *)
+ let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
+ (* ... and the _other_ sort of leaf (god I hate XML). *)
+ let tleaf name attribs = Xml.Element (name, attribs, []) in
+
+ let arch_str =
+ string_of_architecture config_target.tgt_architecture in
+ let arch_wordsize =
+ wordsize_of_architecture config_target.tgt_architecture in
+
+ (* Standard stuff for every domain. *)
+ let name = leaf "name" hostname in
+ let uuid = leaf "uuid" (random_uuid ()) in
+ let maxmem, memory =
+ let m = string_of_int (config_target.tgt_memory * 1024) in
+ leaf "maxmem" m, leaf "memory" m in
+ let vcpu = leaf "vcpu" (string_of_int config_target.tgt_vcpus) in
+
+ (* Top-level stuff which differs for each HV type (isn't this supposed
+ * to be portable ...)
+ *)
+ let extras =
+ (* Use capabilities for os_type, etc. else use some good guesses. *)
+ let os_type = Option.default "hvm" caps_os_type in
+ let machine = Option.default "pc" caps_machine in
+ let loader = Option.default "/usr/lib/xen/boot/hvmloader" caps_loader in
+
+ match config_target.tgt_hypervisor with
+ | Some Xen ->
+ [Xml.Element ("os", [],
+ [leaf "type" os_type;
+ leaf "loader" loader;
+ tleaf "boot" ["dev", "hd"]]);
+ Xml.Element ("features", [],
+ [tleaf "pae" [];
+ tleaf "acpi" [];
+ tleaf "apic" []]);
+ tleaf "clock" ["sync", "localtime"]]
+ | Some KVM ->
+ [Xml.Element ("os", [], [leaf "type" os_type]);
+ tleaf "clock" ["sync", "localtime"]]
+ | Some QEMU ->
+ [Xml.Element ("os", [],
+ [Xml.Element ("type",
+ ["arch", arch_str;
+ "machine", machine],
+ [Xml.PCData os_type]);
+ tleaf "boot" ["dev", "hd"]])]
+ | None ->
+ [] in
+
+ (* <devices> section. *)
+ let devices =
+ let emulator =
+ match caps_emulator with
+ (* Use the emulator from the libvirt capabilities. *)
+ | Some s -> [leaf "emulator" s]
+ | None ->
+ (* If we don't have libvirt capabilities, best guess. *)
+ match config_target.tgt_hypervisor with
+ | Some Xen ->
+ [leaf "emulator"
+ (if arch_wordsize = W64 then "/usr/lib64/xen/bin/qemu-dm"
+ else "/usr/lib/xen/bin/qemu-dm")]
+ | Some QEMU ->
+ [leaf "emulator" "/usr/bin/qemu"]
+ | Some KVM ->
+ [leaf "emulator" "/usr/bin/qemu-kvm"]
+ | None ->
+ [] in
+ let interface =
+ Xml.Element ("interface", ["type", "user"],
+ [tleaf "mac" ["address",
+ config_target.tgt_mac_address]]) in
+ (* XXX should have an option for Xen bridging:
+ Xml.Element (
+ "interface", ["type","bridge"],
+ [tleaf "source" ["bridge","xenbr0"];
+ tleaf "mac" ["address",mac_address];
+ tleaf "script" ["path","vif-bridge"]])*)
+ let graphics = tleaf "graphics" ["type", "vnc"] in
+
+ let disks = List.map (
+ fun (_, _, remote_dev, remote_name) ->
+ Xml.Element (
+ "disk", ["type", "file";
+ "device", "disk"],
+ [tleaf "source" ["file",
+ config_ssh.ssh_directory ^ "/" ^ remote_name];
+ tleaf "target" ["dev", remote_dev]]
+ )
+ ) config_devices_to_send in
+
+ Xml.Element (
+ "devices", [],
+ emulator @ interface :: graphics :: disks
+ ) in
+
+ (* Put it all together in <domain type='foo'>. *)
+ Xml.Element (
+ "domain",
+ (match config_target.tgt_hypervisor with
+ | Some Xen -> ["type", "xen"]
+ | Some QEMU -> ["type", "qemu"]
+ | Some KVM -> ["type", "kvm"]
+ | None -> []),
+ name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
+ ) in
+
+ (* Convert XML configuration file to a string, then send it to the
+ * remote server.
+ *)
+ let () =
+ let xml = Xml.to_string_fmt xml in
+
+ let conn_arg =
+ match config_target.tgt_hypervisor with
+ | Some Xen | None -> ""
+ | Some QEMU | Some KVM -> " -c qemu:///system" in
+ let xml = sprintf (f_ "\
+<!--
+ This is an automatically generated libvirt configuration file.
+ It was written by the %s program.
+
+ Please check the values in this configuration file carefully,
+ particularly maxmem, memory, vcpu and any paths.
+
+ To start the domain, do:
+ virsh%s define %s
+ virsh%s start %s
+-->\n\n") program_name conn_arg conf_filename conn_arg hostname
+ ^ xml
+ ^ "\n" in
+
+ let xml_len = String.length xml in
+ eprintf "length of configuration file is %d bytes\n%!" xml_len;
+
+ print_endline (s_ "\nWriting configuration file ...\n");
+
+ let (sock,_) as conn = ssh_start_upload config_ssh conf_filename in
+ (* In OCaml this actually loops calling write(2) *)
+ ignore (write sock xml 0 xml_len);
+ ssh_finish_upload conn in
+
+ (* Send the device snapshots to the remote host. *)
+ (* XXX This code should be made more robust against both network
+ * errors and local I/O errors. Also should allow the user several
+ * attempts to connect, or let them go back to the dialog stage.
+ *)
+ List.iter (
+ fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
+ eprintf "sending %s as %s\n%!" origin_dev remote_name;
+
+ let size =
+ try List.assoc origin_dev all_block_devices
+ with Not_found -> assert false (* internal error *) in
+
+ let () =
+ printf (f_ "\nSending /dev/%s (%.3f GB) to remote machine\n\n%!")
+ origin_dev ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in
+
+ (* Open the snapshot device. *)
+ let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
+
+ (* Now connect. *)
+ let (sock,_) as conn = ssh_start_upload config_ssh remote_name in
+
+ (* Copy the data. *)
+ let spinners = "|/-\\" (* "Oo" *) in
+ let bufsize = 1024 * 1024 in
+ let buffer = String.create bufsize in
+ let start = gettimeofday () in
+
+ let rec copy bytes_sent last_printed_at spinner =
+ let n = read fd buffer 0 bufsize in
+ if n > 0 then (
+ let n' = write sock buffer 0 n in
+ if n <> n' then assert false; (* never, according to the manual *)
+
+ let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
+ let last_printed_at, spinner =
+ let now = gettimeofday () in
+ (* Print progress every few seconds. *)
+ if now -. last_printed_at > 2. then (
+ let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
+ let secs_elapsed = now -. start in
+ printf "%.0f%% %c %.1f Mbps"
+ (100. *. elapsed) spinners.[spinner]
+ (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
+ (* After 60 seconds has elapsed, start printing estimates. *)
+ if secs_elapsed >= 60. then (
+ let remaining = 1. -. elapsed in
+ let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
+ if secs_remaining > 120. then
+ printf (f_ " (about %.0f minutes remaining)")
+ (secs_remaining/.60.)
+ else
+ printf (f_ " (about %.0f seconds remaining)")
+ secs_remaining
+ );
+ printf " \r%!";
+ let spinner = (spinner + 1) mod String.length spinners in
+ now, spinner
+ )
+ else last_printed_at, spinner in
+
+ copy bytes_sent last_printed_at spinner
+ )
+ in
+ copy 0L start 0;
+ printf "\n\n%!"; (* because of the messages printed above *)
+
+ (* Disconnect. *)
+ ssh_finish_upload conn
+ ) config_devices_to_send;
+
+ (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
+
+ (* Clean up and reboot. *)
ignore (
- dialog [
- title "Error" ();
- msgbox text 17 50
- ]
+ message_box (sprintf (f_ "%s has finished") program_name)
+ (sprintf (f_ "\nThe physical to virtual migration is complete.\n\nPlease verify the disk image(s) and configuration file on the remote host, and then start up the virtual machine by doing:\n\ncd %s\nvirsh define %s\n\nWhen you press [OK] this machine will reboot.")
+ config_ssh.ssh_directory conf_filename)
);
- exit 1
+
+ shfailok "eject";
+ shfailok "reboot";
+
+ exit 0
+
+(*----------------------------------------------------------------------*)
let usage () =
- eprintf "usage: virt-p2v [ttyname]\n%!";
+ let () = eprintf (f_ "usage: virt-p2v [--test] [ttyname]\n%!") in
exit 2
+(* Make sure that exceptions from 'main' get printed out on stdout
+ * as well as stderr, since stderr is probably redirected to the
+ * logfile, and so not visible to the user.
+ *)
+let handle_exn f arg =
+ try f arg
+ with exn ->
+ print_endline (Printexc.to_string exn);
+ raise exn
+
(* Test harness for the Makefile. The Makefile invokes this script as
- * 'virt-p2v.ml --test' just to check it compiles. When it is running
+ * '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.ml tty1').
+ * tty name (so usually 'virt-p2v tty1').
*)
let () =
match Array.to_list Sys.argv with
- | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
| [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
- | [ _; ttyname ] -> main (Some ttyname) (* Run main with ttyname. *)
- | [ _ ] -> main None (* Interactive - no ttyname. *)
+ | [ _; "--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 *)
git.annexia.org / virt-p2v.git / blobdiff