* 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;
- static_network_config : static_network_config 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
- | QEMUUserNet
- | Static
-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
-and static_network_config = string * string * string * string * string
- (* interface, address, netmask, gateway, nameserver *)
+type partition =
+ | Part of string * string (* eg. "hda", "1" *)
+ | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
+type transfer =
+ | P2V (* physical to virtual *)
+ | V2V (* virtual to virtual *)
+ (*| V2P*) (* virtual to physical - not impl *)
+type network =
+ | Auto of partition (* Automatic network configuration. *)
+ | Shell (* Start a shell. *)
+ | QEMUUserNet (* Assume we're running under qemu. *)
+ | Static of string * string * string * string * string
+ (* interface, address, netmask, gateway, nameserver *)
+ | NoNetwork
+type hypervisor =
+ | Xen
+ | QEMU
+ | KVM
+type architecture =
+ | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
+ | OtherArch of string
+ | UnknownArch
(*----------------------------------------------------------------------*)
-(* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
+(* 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;
- (* 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;
- static_network_config = None;
- hypervisor = None;
- architecture = None;
- memory = None;
- vcpus = None;
- mac_address = 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
+
+(* General type of transfer. *)
+let config_transfer_type = ref None
+
+(* Network configuration. *)
+let config_network = ref None
+
+(* SSH configuration. *)
+let config_remote_host = ref None
+let config_remote_port = ref None
+let config_remote_directory = ref None
+let config_remote_username = ref None
+let config_remote_password = ref None
+let config_ssh_check = ref None
+let config_libvirtd_check = ref None
+
+(* What to transfer. *)
+let config_devices_to_send = ref None
+let config_root_filesystem = ref None
+
+(* Configuration of the target. *)
+let config_hypervisor = ref None
+let config_architecture = ref None
+let config_memory = ref None
+let config_vcpus = ref None
+let config_mac_address = ref None
+let config_compression = ref None
+
+(* The name of the program as displayed in various places. *)
+let program_name = "virt-p2v"
+
+(* If you want to test the dialog stages, set this to true. *)
+let test_dialog_stages = false
+
(* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
(*----------------------------------------------------------------------*)
+(* Load external libraries. *)
+;;
+#load "unix.cma";;
+#directory "+extlib";;
+#load "extLib.cma";;
+#directory "+pcre";;
+#load "pcre.cma";;
+#directory "+newt";;
+#load "mlnewt.cma";;
+#directory "+xml-light";;
+#load "xml-light.cma";;
+
+open Unix
+open Printf
+open ExtList
+open ExtString
+
+(*----------------------------------------------------------------------*)
(* General helper functions. *)
let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
| 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: *)
| 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.
+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.
*
- * Returns the exit status (Yes lines | No | Help | Back | Error).
+ * 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 msgbox, yesno, inputbox, radiolist, checklist, form =
- (* 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
- )
+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
+ )
- (* Form. *)
- and form =
- with_common (
- fun cparams text height width formheight items ->
- let items = List.map (
- fun (label, y, x, item, y', x', flen, ilen) ->
- [ label; string_of_int y; string_of_int x; item;
- string_of_int y'; string_of_int x';
- string_of_int flen; string_of_int ilen ]
- ) items in
- let items = List.concat items in
- let items = "--form" :: text ::
- string_of_int height :: string_of_int width ::
- string_of_int formheight :: items in
- run_dialog cparams items
- )
- in
- msgbox, yesno, inputbox, radiolist, checklist, form
+(* Clear the screen, open a new centered window, make sure the background
+ * and help messages are consistent.
+ *)
+let open_centered_window ?stage width height title =
+ if not !in_newt then failwith "open_centered_window: not in newt mode";
+ Newt.cls ();
+ Newt.centered_window width height title;
+ let root_text =
+ program_name ^ (match stage with
+ | None -> ""
+ | Some stage -> " - " ^ stage) in
+ Newt.draw_root_text 0 0 root_text;
+ Newt.push_help_line "F12 for next screen | [ALT] [F2] root / no password for shell"
+
+(* Some general dialog boxes. *)
+let message_box title text =
+ with_newt (
+ fun () ->
+ open_centered_window 40 20 title;
+
+ let textbox = Newt.textbox 1 1 36 14 [Newt.WRAP; Newt.SCROLL] in
+ Newt.textbox_set_text textbox text;
+ let ok = Newt.button 28 16 " OK " in
+ let form = Newt.form None None [] in
+ Newt.form_add_component form textbox;
+ Newt.form_add_component form ok;
+
+ Newt.component_takes_focus ok true;
+
+ ignore (Newt.run_form form);
+ Newt.pop_window ()
+ )
-(* Print failure dialog and exit. *)
-let fail_dialog text =
+(* Fail and exit with error. *)
+let failwith text =
+ prerr_endline text;
let text = "\n" ^ text ^ "\n\nIf you want to report this error, there is a shell on [ALT] [F2], log in as root with no password.\n\nPlease provide the contents of /tmp/virt-p2v.log and output of the 'dmesg' command." in
- ignore (msgbox "Error" text 17 50);
+ message_box "Error" text;
exit 1
(* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
(* 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)
+ if Sys.command cmd <> 0 then failwith (sprintf "Command failed:\n\n%s" cmd)
let shfailok cmd =
eprintf "shfailok: %s\n%!" cmd;
try Some ((stat path).st_kind = S_REG)
with Unix_error (ENOENT, "stat", _) -> None
-(* Useful regular expression. *)
-let whitespace = Pcre.regexp "[ \t]+"
+(*----------------------------------------------------------------------*)
+(* P2V-specific helper functions. *)
(* Generate a predictable safe name containing only letters, numbers
* and underscores. If passed a string with no letters or numbers,
with
| None -> []
| Some lines ->
- let lines = List.map (Pcre.split ~rex:whitespace) lines in
+ let lines = List.map Pcre.split lines in
List.map (
function
| [vg; lv; pvs; lvsize]
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
+ failwith (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
(* Create the snapshot origin device. Called, eg. snap_sda1_org *)
sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
(* Try to perform automatic network configuration, assuming a Fedora or
* RHEL-like root filesystem mounted on /mnt/root.
*)
-let auto_network state =
+let auto_network () =
(* 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
+ (* 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);
+ (* 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 state.greeting then (
+ if !config_greeting then (
printf "\n\nDid automatic network configuration work?\n";
printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
printf " (y/n) %!";
status = 0
(* Configure the network statically. *)
-let static_network state =
- match state.static_network_config with
- | None -> false (* failed *)
- | Some (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 *)
+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";
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 Pcre.split lines in
let lines = List.map (
function
| dev :: rest when String.starts_with dev "/dev/" ->
fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
dev mountpoint fstype options freq passno
| line ->
- output_string chan (String.concat " " line)
+ output_string chan (String.concat " " line);
+ output_char chan '\n'
) lines;
close_out chan
)
-let () = Random.self_init ()
-
+(* Generate a random MAC address in the Xen-reserved space. *)
let random_mac_address () =
let random =
List.map (sprintf "%02x") (
) in
String.concat ":" ("00"::"16"::"3e"::random)
+(* Generate a random UUID. *)
let random_uuid =
let hex = "0123456789abcdef" in
fun () ->
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\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. *)
dup2 fd stdin;
dup2 fd stdout;
close fd);
- printf "virt-p2v starting up ...\n%!";
+ printf "%s starting up ...\n%!" program_name;
(* Disable screen blanking on tty. *)
sh "setterm -blank 0";
(* Check that the environment is a sane-looking live CD. If not, bail. *)
- if is_dir "/mnt/root" <> Some true then
- fail_dialog
+ if not test_dialog_stages && is_dir "/mnt/root" <> Some true then
+ failwith
"You should only run this script from the live CD or a USB key.";
- printf "virt-p2v detecting hard drives (this may take some time) ...\n%!";
+ (* Start of the information gathering phase. *)
+ printf "%s detecting hard drives (this may take some time) ...\n%!"
+ program_name;
(* Search for all non-removable block devices. Do this early and bail
* if we can't find anything. This is a list of strings, like "hda".
(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 "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
) all_partitions
in
- printf "virt-p2v finished detecting hard drives\n%!";
+ printf "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
+ (* Autodetect system memory. *)
+ let system_memory =
+ let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
+ match mem with
+ | Some (mem::_) -> int_of_float (float_of_string mem)
+ | _ -> 256 in
+
+ (* Autodetect system # pCPUs. *)
+ let system_nr_cpus =
+ let cpus =
+ shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
+ match cpus with
+ | Some (cpus::_) -> int_of_string cpus
+ | _ -> 1 in
+
+ (* Greeting, type of transfer, network question stages.
+ * These are all done in newt mode.
+ *)
+ let config_transfer_type, config_network =
+ with_newt (
+ fun () ->
+ (* Greeting. *)
+ if !config_greeting then
+ message_box program_name (sprintf "Welcome to %s, a live CD for migrating a physical machine to a virtualized host.\n\nTo continue press the Return key.\n\nTo get a shell you can use [ALT] [F2] and log in as root with no password.\n\nExtra information is logged in /tmp/virt-p2v.log but this file disappears when the machine reboots." program_name);
+
+ (* Type of transfer. *)
+ let config_transfer_type =
+ match !config_transfer_type with
+ | Some t -> t
+ | None ->
+ let rec loop () =
+ open_centered_window ~stage:"Transfer type"
+ 40 10 "Transfer type";
+
+ let p2v =
+ Newt.radio_button 1 1 "Physical to virtual (P2V)" true
+ None in
+ let v2v =
+ Newt.radio_button 1 2 "Virtual to virtual (V2V)" false
+ (Some p2v) in
+ let ok = Newt.button 28 6 " OK " in
+
+ let form = Newt.form None None [] in
+ Newt.form_add_components form [p2v; v2v];
+ Newt.form_add_component form ok;
+
+ ignore (Newt.run_form form);
+ Newt.pop_window ();
+
+ let r = Newt.radio_get_current p2v in
+ if Newt.component_equals r p2v then P2V
+ else if Newt.component_equals r v2v then V2V
+ else loop ()
+ in
+ loop () in
+
+ (* Network configuration. *)
+ let config_network =
+ match !config_network with
+ | Some n -> n
+ | None ->
+ let rec loop () =
+ open_centered_window ~stage:"Network"
+ 60 20 "Configure network";
+
+ let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in
+ Newt.listbox_set_width autolist 52;
+
+ (* Populate the "Automatic" listbox with RHEL/Fedora
+ * root partitions found which allow us to do
+ * automatic configuration in a known way.
+ *)
+ let partition_map = Hashtbl.create 13 in
+ let maplen = ref 1 in
+ let rec iloop = function
+ | [] -> ()
+ | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
+ :: parts ->
+ let label =
+ sprintf "%s (%s)"
+ (dev_of_partition partition)
+ (string_of_linux_distro distro) in
+ Hashtbl.add partition_map (!maplen) partition;
+ ignore (
+ Newt.listbox_append_entry autolist label (!maplen)
+ );
+ incr maplen;
+ iloop parts
+ | _ :: parts -> iloop parts
+ in
+ iloop all_partitions;
+
+ (* If there is no suitable root partition (the listbox
+ * is empty) then disable the auto option and the listbox.
+ *)
+ let no_auto = Hashtbl.length partition_map = 0 in
+
+ let auto =
+ Newt.radio_button 1 1
+ "Automatic from:" (not no_auto) None in
+ let shell =
+ Newt.radio_button 1 6
+ "Start a shell" no_auto (Some auto) in
+
+ if no_auto then (
+ Newt.component_takes_focus auto false;
+ Newt.component_takes_focus autolist false
+ );
+
+ let qemu =
+ Newt.radio_button 1 7
+ "QEMU user network" false (Some shell) in
+ let nonet =
+ Newt.radio_button 1 8
+ "No network or network already configured" false
+ (Some qemu) in
+ let static =
+ Newt.radio_button 1 9
+ "Static configuration:" false (Some nonet) in
+
+ let label1 = Newt.label 4 10 "Interface" in
+ let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
+ let label2 = Newt.label 4 11 "Address" in
+ let entry2 = Newt.entry 16 11 None 16 [] in
+ let label3 = Newt.label 4 12 "Netmask" in
+ let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
+ let label4 = Newt.label 4 13 "Gateway" in
+ let entry4 = Newt.entry 16 13 None 16 [] in
+ let label5 = Newt.label 4 14 "Nameserver" in
+ let entry5 = Newt.entry 16 14 None 16 [] in
+
+ let enable_static () =
+ Newt.component_takes_focus entry1 true;
+ Newt.component_takes_focus entry2 true;
+ Newt.component_takes_focus entry3 true;
+ Newt.component_takes_focus entry4 true;
+ Newt.component_takes_focus entry5 true
+ in
+
+ let disable_static () =
+ Newt.component_takes_focus entry1 false;
+ Newt.component_takes_focus entry2 false;
+ Newt.component_takes_focus entry3 false;
+ Newt.component_takes_focus entry4 false;
+ Newt.component_takes_focus entry5 false
+ in
+
+ let enable_autolist () =
+ Newt.component_takes_focus autolist true
+ in
+ let disable_autolist () =
+ Newt.component_takes_focus autolist false
+ in
+
+ disable_static ();
+ Newt.component_add_callback auto
+ (fun () ->disable_static (); enable_autolist ());
+ Newt.component_add_callback shell
+ (fun () -> disable_static (); disable_autolist ());
+ Newt.component_add_callback qemu
+ (fun () -> disable_static (); disable_autolist ());
+ Newt.component_add_callback nonet
+ (fun () -> disable_static (); disable_autolist ());
+ Newt.component_add_callback static
+ (fun () -> enable_static (); disable_autolist ());
+
+ let ok = Newt.button 28 16 " OK " in
+
+ let form = Newt.form None None [] in
+ Newt.form_add_component form auto;
+ Newt.form_add_component form autolist;
+ Newt.form_add_components form [shell;qemu;nonet;static];
+ Newt.form_add_components form
+ [label1;label2;label3;label4;label5];
+ Newt.form_add_components form
+ [entry1;entry2;entry3;entry4;entry5];
+ Newt.form_add_component form ok;
+
+ ignore (Newt.run_form form);
+ Newt.pop_window ();
+
+ let r = Newt.radio_get_current auto in
+ if Newt.component_equals r auto then (
+ match Newt.listbox_get_current autolist with
+ | None -> loop ()
+ | Some i -> Auto (Hashtbl.find partition_map i)
+ )
+ else if Newt.component_equals r shell then Shell
+ else if Newt.component_equals r qemu then QEMUUserNet
+ else if Newt.component_equals r nonet then NoNetwork
+ else if Newt.component_equals r static then (
+ let interface = Newt.entry_get_value entry1 in
+ let address = Newt.entry_get_value entry2 in
+ let netmask = Newt.entry_get_value entry3 in
+ let gateway = Newt.entry_get_value entry4 in
+ let nameserver = Newt.entry_get_value entry5 in
+ if interface = "" || address = "" ||
+ netmask = "" || gateway = "" then
+ loop ()
+ else
+ Static (interface, address, netmask, gateway, nameserver)
+ )
+ else loop ()
+ in
+ loop () in
+
+ config_transfer_type, config_network
+ ) in
+ (* Try to bring up the network. *)
+ (match config_network with
+ | Shell ->
+ printf "Network configuration.\n\n";
+ printf "Please configure the network from this shell.\n\n";
+ printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
+ shell ()
+
+ | Static (interface, address, netmask, gateway, nameserver) ->
+ printf "Trying static network configuration.\n\n%!";
+ if not (static_network
+ (interface, address, netmask, gateway, nameserver)) then (
+ printf "\nAuto-configuration failed. Starting a shell.\n\n";
+ printf "Please configure the network from this shell.\n\n";
+ printf "When you have finished, exit the shell with ^D or exit.\n\n";
+ shell ()
+ )
+
+ | Auto rootfs ->
+ printf
+ "Trying network auto-configuration from root filesystem ...\n\n%!";
+
+ (* Mount the root filesystem read-only under /mnt/root. *)
+ sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");
+
+ if not (auto_network ()) then (
+ printf "\nAuto-configuration failed. Starting a shell.\n\n";
+ printf "Please configure the network from this shell.\n\n";
+ printf "When you have finished, exit the shell with ^D or exit.\n\n";
+ shell ()
+ );
+
+ (* NB. Lazy unmount is required because dhclient keeps its current
+ * directory open on /etc/sysconfig/network-scripts/
+ *)
+ sh ("umount -l /mnt/root");
+
+ | QEMUUserNet ->
+ printf "Trying QEMU network configuration.\n\n%!";
+ qemu_network ()
+
+ | NoNetwork -> (* this is easy ... *) ()
+ );
+
+(*
let ask_hostname state =
match
inputbox "Remote host" "Remote host" 10 50
| Back -> Prev
in
- let ask_network state =
- match
- radiolist "Network configuration" "Network configuration" 12 50 4 [
- "auto", "Automatic configuration", state.network = Some Auto;
- "ask", "Ask for fixed IP address and gateway",
- state.network = Some Static;
- "sh", "Configure from the shell", state.network = Some Shell;
- "qemu", "QEMU user network (for developers only)",
- state.network = Some QEMUUserNet
- ]
- with
- | Yes ("auto"::_) -> Next { state with network = Some Auto }
- | Yes ("ask"::_) -> Next { state with network = Some Static }
- | Yes ("sh"::_) -> Next { state with network = Some Shell }
- | Yes ("qemu"::_) -> Next { state with network = Some QEMUUserNet }
- | Yes _ | No | Help | Error -> Ask_again
- | Back -> Prev
- in
-
- let ask_static_network_config state =
- let interface, address, netmask, gateway, nameserver =
- match state.static_network_config with
- | Some (a,b,c,d,e) -> a,b,c,d,e
- | None -> "eth0","","","","" in
- match
- form "Static network configuration" "Static network configuration"
- 13 50 5 [
- "Interface", 1, 0, interface, 1, 12, 8, 0;
- "Address", 2, 0, address, 2, 12, 16, 0;
- "Netmask", 3, 0, netmask, 3, 12, 16, 0;
- "Gateway", 4, 0, gateway, 4, 12, 16, 0;
- "Nameserver", 5, 0, nameserver, 5, 12, 16, 0;
- ]
- with
- | Yes (interface::address::netmask::gateway::nameserver::_) ->
- Next { state with
- static_network_config = Some (interface, address, netmask,
- gateway, nameserver) }
- | 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 (
| Back -> Prev
in
+ let ask_compression state =
+ match
+ radiolist "Network compression" "Enable network compression" 10 50 2 [
+ "yes", "Yes, compress network traffic", state.compression <> Some false;
+ "no", "No, don't compress", state.compression = Some false
+ ]
+ with
+ | Yes ("no"::_) -> Next { state with compression = Some false }
+ | Yes _ -> Next { state with compression = Some true }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
let ask_verify state =
match
yesno "Verify and proceed"
Architecture: %s
Memory: %s
VCPUs: %s
-MAC address: %s"
+MAC address: %s
+Compression: %b"
(Option.default "" state.remote_host)
(Option.default "" state.remote_port)
(Option.default "" state.remote_directory)
| Some vcpus -> string_of_int vcpus | None -> "")
(match state.mac_address with
| Some "" -> "Random" | Some mac -> mac | None -> "")
+ (Option.default true state.compression)
)
21 50
with
ask_memory, defaults.memory <> None, dont_skip;
ask_vcpus, defaults.vcpus <> None, dont_skip;
ask_mac_address, defaults.mac_address <> None, dont_skip;
+ ask_compression, defaults.compression <> None, dont_skip;
ask_verify, not defaults.greeting, dont_skip;
|] in
eprintf "finished dialog loop\n%!";
+ (* In test mode, exit here before we do bad things to the developer's
+ * hard disk.
+ *)
+ if test_dialog_stages then exit 1;
+
(* Switch LVM config. *)
sh "vgchange -a n";
putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
sh ("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 ()
-
- | Static ->
- printf "Trying static network configuration.\n\n%!";
- if not (static_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 ()
- )
-
- | 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 ()
- )
- | QEMUUserNet ->
- printf "Trying QEMU network configuration.\n\n%!";
- qemu_network ()
- );
-
(* Work out what devices will be called at the remote end. *)
let devices_to_send = List.map (
fun (origin_dev, snapshot_dev) ->
| 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
(* 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\""
+ let cmd = sprintf "ssh%s -l %s -p %s %s \"cat > %s/%s\""
+ (if state.compression = Some false then "" else " -C")
(quote remote_username) (quote remote_port) (quote remote_host)
(quote remote_directory) (quote remote_name) in
eprintf "connect: %s\n%!" cmd;
let (sock,_) as conn = do_connect remote_name size in
(* Copy the data. *)
+ let spinners = "|/-\\" (* "Oo" *) in
let bufsize = 1024 * 1024 in
let buffer = String.create bufsize in
let start = gettimeofday () in
- let rec copy bytes_sent last_printed_at =
+ let rec copy bytes_sent last_printed_at spinner =
let n = read fd buffer 0 bufsize in
if n > 0 then (
- ignore (write sock buffer 0 n);
+ 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 =
+ let last_printed_at, spinner =
let now = gettimeofday () in
(* Print progress every few seconds. *)
- if now -. last_printed_at > 5. then (
+ 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%%" (100. *. elapsed);
+ printf "%.0f%% %c %.1f Mbps"
+ (100. *. elapsed) spinners.[spinner]
+ (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
(* After 60 seconds has elapsed, start printing estimates. *)
if secs_elapsed >= 60. then (
let remaining = 1. -. elapsed in
let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
if secs_remaining > 120. then
- printf " (about %.0f minutes remaining) "
- (secs_remaining /. 60.)
+ printf " (about %.0f minutes remaining)" (secs_remaining/.60.)
else
- printf " (about %.0f seconds remaining) "
+ printf " (about %.0f seconds remaining)"
secs_remaining
);
- printf "\r%!";
- now
+ printf " \r%!";
+ let spinner = (spinner + 1) mod String.length spinners in
+ now, spinner
)
- else last_printed_at in
+ else last_printed_at, spinner in
- copy bytes_sent last_printed_at
+ copy bytes_sent last_printed_at spinner
)
in
- copy 0L start;
+ copy 0L start 0;
+ printf "\n\n%!"; (* because of the messages printed above *)
(* Disconnect. *)
do_disconnect conn
) devices_to_send;
+ (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
+
(* Clean up and reboot. *)
ignore (
- msgbox "virt-p2v completed"
+ msgbox (sprintf "%s completed" program_name)
(sprintf "\nThe physical to virtual migration is complete.\n\nPlease verify the disk image(s) and configuration file on the remote host, and then start up the virtual machine by doing:\n\ncd %s\nvirsh define %s\n\nWhen you press [OK] this machine will reboot."
remote_directory conf_filename)
17 50
shfailok "eject";
shfailok "reboot";
+*)
exit 0
+(*----------------------------------------------------------------------*)
+
let usage () =
eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
exit 2
*)
let handle_exn f arg =
try f arg
- with exn -> print_endline (Printexc.to_string exn); raise exn
+ 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
git.annexia.org / virt-p2v.git / blobdiff