| 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
| I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
| OtherArch of string
| UnknownArch
+type target_config = {
+ tgt_hypervisor : hypervisor option; (* Remote hypervisor. *)
+ tgt_architecture : architecture; (* Remote architecture. *)
+ tgt_memory : int; (* Memory (megabytes). *)
+ tgt_vcpus : int; (* Number of virtual CPUs. *)
+ tgt_mac_address : string; (* MAC address. *)
+ tgt_libvirtd : bool; (* True if libvirtd on remote. *)
+}
(*----------------------------------------------------------------------*)
(* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section.
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
+let config_ssh = 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
+let config_target = ref None
(* The name of the program as displayed in various places. *)
let program_name = "virt-p2v"
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.form_add_components form [textbox; ok];
Newt.component_takes_focus ok true;
message_box "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 " 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 " 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
let get_lvs =
let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
- function () ->
+ fun () ->
match
shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
with
(* 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
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 "ssh: exited with error code %d" i)
+ | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
+ | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
+
+(* 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 =
+ printf "Testing SSH connection by listing files in remote directory ...\n\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 (
+ printf "\n\nDid SSH work?\n";
+ printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
+ printf " (y/n) %!";
+ let line = read_line () in
+ String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
+ )
+ else
+ true
+
(* Rewrite /mnt/root/etc/fstab. *)
-let rewrite_fstab state devices_to_send =
+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"));
"You should only run this script from the live CD or a USB key.";
(* Start of the information gathering phase. *)
- printf "%s detecting hard drives (this may take some time) ...\n%!"
- program_name;
+ printf "Detecting hard drives (this may take some time) ...\n%!";
(* Search for all non-removable block devices. Do this early and bail
* if we can't find anything. This is a list of strings, like "hda".
) all_partitions
in
- printf "finished detecting hard drives\n%!";
+ printf "Finished detecting hard drives.\n%!";
(* Autodetect system memory. *)
let system_memory =
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 items = [
+ "Physical to Virtual (P2V)", P2V;
+ "Virtual to Virtual (V2V)", V2V;
+ ] 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
+ select_single ~stage:"Transfer type" 40
+ "Transfer type"
+ items 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
+ 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 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
+ "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
+ (Newt.component_of_listbox autolist) false
+ );
- let enable_autolist () =
- Newt.component_takes_focus autolist true
- in
- let disable_autolist () =
- Newt.component_takes_focus autolist false
- in
+ 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
- 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;
+ 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
- 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 ()
+ let enable_autolist () =
+ Newt.component_takes_focus
+ (Newt.component_of_listbox autolist) true
in
- loop () 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 " 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
| NoNetwork -> (* this is easy ... *) ()
);
-(*
- let ask_hostname state =
- match
- inputbox "Remote host" "Remote host" 10 50
- (Option.default "" state.remote_host)
- with
- | Yes [] -> Ask_again
- | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
- | No | Help | Error -> Ask_again
- | Back -> Prev
- in
-
- let ask_port state =
- match
- inputbox "Remote port" "Remote port" 10 50
- (Option.default "22" state.remote_port)
- with
- | Yes ([]|""::_) -> Next { state with remote_port = Some "22" }
- | Yes (port::_) -> Next { state with remote_port = Some port }
- | No | Help | Error -> Ask_again
- | Back -> Prev
- in
-
- let ask_directory state =
- let default_dir = "/var/lib/xen/images" in
- match
- inputbox "Remote directory" "Remote directory" 10 50
- (Option.default default_dir state.remote_directory)
- with
- | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir }
- | Yes (dir::_) -> Next { state with remote_directory = Some dir }
- | No | Help | Error -> Ask_again
- | Back -> Prev
- in
-
- let ask_username state =
- let default_username = "root" in
- match
- inputbox "Remote username" "Remote username for ssh access to server" 10 50
- (Option.default default_username state.remote_username)
- with
- | Yes ([]|""::_) ->
- Next { state with remote_username = Some default_username }
- | Yes (user::_) -> Next { state with remote_username = Some user }
- | No | Help | Error -> Ask_again
- | Back -> Prev
- in
-
- let ask_devices state =
- let selected_devices = Option.default [] state.devices_to_send in
- let devices = List.map (
- fun (dev, blksize) ->
- (dev,
- sprintf "/dev/%s (%.3f GB)" dev
- ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
- List.mem dev selected_devices)
- ) all_block_devices in
- match
- checklist "Devices" "Pick devices to send" 15 50 8 devices
- with
- | Yes [] | No | Help | Error -> Ask_again
- | Yes devices -> Next { state with devices_to_send = Some devices }
- | Back -> Prev
- in
-
- let ask_root state =
- let parts = List.mapi (
- fun i (part, nature) ->
- let descr =
- match nature with
- | LinuxSwap -> " (Linux swap)"
- | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
- | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
- | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
- | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
- | WindowsRoot -> " (Windows C:)"
- | LinuxBoot -> " (Linux /boot)"
- | NotRoot -> " (filesystem)"
- | UnknownNature -> "" in
- (string_of_int i,
- dev_of_partition part ^ descr,
- Some part = state.root_filesystem)
- ) all_partitions in
- match
- radiolist "Root device"
- "Pick partition containing the root (/) filesystem" 18 70 9
- parts
- with
- | Yes (i::_) ->
- let (part, _) = List.nth all_partitions (int_of_string i) in
- Next { state with root_filesystem = Some part }
- | Yes [] | No | Help | Error -> Ask_again
- | Back -> Prev
- in
-
- let ask_hypervisor state =
- match
- radiolist "Hypervisor"
- "Choose hypervisor / virtualization system"
- 11 50 4 [
- "xen", "Xen", state.hypervisor = Some Xen;
- "qemu", "QEMU", state.hypervisor = Some QEMU;
- "kvm", "KVM", state.hypervisor = Some KVM;
- "other", "Other", state.hypervisor = None
- ]
- with
- | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
- | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
- | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
- | Yes _ -> Next { state with hypervisor = None }
- | No | Help | Error -> Ask_again
- | Back -> Prev
- in
-
- let ask_architecture state =
- match
- radiolist "Architecture" "Machine architecture" 16 50 8 [
- "i386", "i386 and up (32 bit)", state.architecture = Some I386;
- "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
- "ia64", "Itanium IA64", state.architecture = Some IA64;
- "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
- "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
- "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
- "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
- "auto", "Auto-detect",
- state.architecture = None || state.architecture = Some UnknownArch;
- ]
- with
- | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
- | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
- | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
- | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
- | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
- | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
- | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
- | Yes _ -> Next { state with architecture = Some UnknownArch }
- | No | Help | Error -> Ask_again
- | Back -> Prev
- in
+ (* 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:"SSH configuration"
+ 60 20 "SSH configuration";
+
+ let label1 = Newt.label 1 1 "Remote host" in
+ let host = Newt.entry 20 1 None 36 [] in
+ let label2 = Newt.label 1 2 "Remote port" in
+ let port = Newt.entry 20 2 (Some "22") 6 [] in
+ let label3 = Newt.label 1 3 "Remote directory" in
+ let dir = Newt.entry 20 3 (Some "/var/lib/xen/images") 36 [] in
+ let label4 = Newt.label 1 4 "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 "SSH password" in
+ let pass = Newt.entry 20 5 None 16 [Newt.PASSWORD] in
+ *)
+
+ let compr =
+ Newt.checkbox 16 7 "Use SSH compression (not good for LANs)"
+ ' ' None in
+
+ let check = Newt.checkbox 16 9 "Test SSH connection" '*' None in
+
+ let ok = Newt.button 48 16 " OK " 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
- let ask_memory state =
- match
- inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
- 10 50
- (Option.map_default string_of_int "" state.memory)
- with
- | Yes (""::_ | []) -> Next { state with memory = Some 0 }
- | Yes (mem::_) ->
- let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
- if mem < 0 || (mem > 0 && mem < 64) then Ask_again
- else Next { state with memory = Some mem }
- | No | Help | Error -> Ask_again
- | Back -> Prev
- in
+ Newt.pop_window ();
+ c
+ ) in
- let ask_vcpus state =
- match
- inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
- 10 50
- (Option.map_default string_of_int "" state.vcpus)
- with
- | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
- | Yes (vcpus::_) ->
- let vcpus =
- try int_of_string vcpus with Failure "int_of_string" -> -1 in
- if vcpus < 0 then Ask_again
- else Next { state with vcpus = Some vcpus }
- | No | Help | Error -> Ask_again
- | Back -> Prev
- in
+ (* If asked, check the SSH connection. *)
+ if config_ssh.ssh_check then
+ if not (test_ssh config_ssh) then
+ failwith "SSH configuration failed";
- let ask_mac_address state =
- match
- inputbox "MAC address"
- "Network MAC address. Leave blank to use a random address." 10 50
- (Option.default "" state.mac_address)
- with
- | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
- | Yes (mac :: _) -> Next { state with mac_address = Some mac }
- | No | Help | Error -> Ask_again
- | Back -> Prev
- in
-
- let ask_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
+ (* 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:"Block devices" ~force_one:true 60
+ "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:"Root filesystem" 60
+ "Select root filesystem"
+ items in
+
+ let config_target =
+ match !config_target with
+ | Some t -> t
+ | None ->
+ open_centered_window ~stage:"Target system" 40 20
+ "Configure target system";
+
+ let hvlabel = Newt.label 1 1 "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 "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 "Memory (MB):" in
+ let mementry = Newt.entry 16 9
+ (Some (string_of_int system_memory)) 8 [] in
+ let cpulabel = Newt.label 1 10 "CPUs:" in
+ let cpuentry = Newt.entry 16 10
+ (Some (string_of_int system_nr_cpus)) 4 [] in
+ let maclabel = Newt.label 1 11 "MAC addr:" in
+ let macentry = Newt.entry 16 11 None 20 [] in
+ let maclabel2 = Newt.label 1 12 "(leave MAC blank for random)" in
+
+ let libvirtd =
+ Newt.checkbox 12 14 "Use remote libvirtd" '*' None in
+
+ let ok = Newt.button 28 16 " OK " 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
- let ask_verify state =
- match
- yesno "Verify and proceed"
- (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
-
-Host:port: %s : %s
-Directory: %s
-Network: %s
-Send devices: %s
-Root (/) dev: %s
-Hypervisor: %s
-Architecture: %s
-Memory: %s
-VCPUs: %s
-MAC address: %s
-Compression: %b"
- (Option.default "" state.remote_host)
- (Option.default "" state.remote_port)
- (Option.default "" state.remote_directory)
- (match state.network with
- | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
- | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net"
- | None -> "")
- (String.concat "," (Option.default [] state.devices_to_send))
- (Option.map_default dev_of_partition "" state.root_filesystem)
- (match state.hypervisor with
- | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
- | None -> "Other / not set")
- (match state.architecture with
- | Some UnknownArch -> "Auto-detect"
- | Some arch -> string_of_architecture arch | None -> "")
- (match state.memory with
- | Some 0 -> "Same as physical"
- | Some mem -> string_of_int mem ^ " MB" | None -> "")
- (match state.vcpus with
- | Some 0 -> "Same as physical"
- | Some vcpus -> string_of_int vcpus | None -> "")
- (match state.mac_address with
- | Some "" -> "Random" | Some mac -> mac | None -> "")
- (Option.default true state.compression)
- )
- 21 50
- with
- | Yes _ -> Next state
- | Back -> Prev
- | No | Help | Error -> Ask_again
- in
+ Newt.pop_window ();
- (* This is the list of dialogs, in order. The user can go forwards or
- * backwards through them.
- *
- * The second parameter in each tuple is true if we need to skip
- * this dialog statically (info already supplied in 'defaults' above).
- *
- * The third parameter in each tuple is a function that tests whether
- * this dialog should be skipped, given other parts of the current state.
- *)
- let dlgs =
- let dont_skip _ = false in
- [|
- ask_greeting, not defaults.greeting, dont_skip;
- ask_hostname, defaults.remote_host <> None, dont_skip;
- ask_port, defaults.remote_port <> None, dont_skip;
- ask_directory, defaults.remote_directory <> None, dont_skip;
- ask_username, defaults.remote_username <> None, dont_skip;
- ask_network, defaults.network <> None, dont_skip;
- ask_static_network_config,
- defaults.static_network_config <> None,
- (function { network = Some Static } -> false | _ -> true);
- ask_devices, defaults.devices_to_send <> None, dont_skip;
- ask_root, defaults.root_filesystem <> None, dont_skip;
- ask_hypervisor, defaults.hypervisor <> None, dont_skip;
- ask_architecture, defaults.architecture <> None, dont_skip;
- 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
-
- (* Loop through the dialogs until we reach the end. *)
- let rec loop ?(back=false) posn state =
- eprintf "dialog loop: posn = %d, back = %b\n%!" posn back;
- if posn >= Array.length dlgs then state (* Finished all dialogs. *)
- else if posn < 0 then loop 0 state
- else (
- let dlg, skip_static, skip_dynamic = dlgs.(posn) in
- if skip_static || skip_dynamic state then
- (* Skip this dialog. *)
- loop ~back (if back then posn-1 else posn+1) state
- else (
- (* Run dialog. *)
- match dlg state with
- | Next new_state -> loop (posn+1) new_state (* Forwards. *)
- | Ask_again -> loop posn state (* Repeat the question. *)
- | Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *)
- )
- )
- in
- let state = loop 0 defaults in
+ c in
- eprintf "finished dialog loop\n%!";
+ config_devices_to_send, config_root_filesystem, config_target
+ ) in
- (* In test mode, exit here before we do bad things to the developer's
+ (* In test mode, exit here before we do Bad Things to the developer's
* hard disk.
*)
if test_dialog_stages then exit 1;
sh "rm -f /etc/lvm.new/cache/.cache";
(* Snapshot the block devices to send. *)
- let devices_to_send = Option.get state.devices_to_send in
- let devices_to_send =
+ 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)
- ) devices_to_send in
+ ) config_devices_to_send in
(* Run kpartx on the snapshots. *)
List.iter (
fun (origin, snapshot) ->
shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
- ) devices_to_send;
+ ) config_devices_to_send;
(* Rescan for LVs. *)
sh "vgscan";
sh "vgchange -a y";
(* Mount the root filesystem under /mnt/root. *)
- let root_filesystem = Option.get state.root_filesystem in
- (match root_filesystem with
+ (match config_root_filesystem with
| Part (dev, partnum) ->
let dev = dev ^ partnum in
let snapshot_dev = snapshot_name dev in
);
(* Work out what devices will be called at the remote end. *)
- let devices_to_send = List.map (
+ 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)
- ) devices_to_send in
+ ) config_devices_to_send in
(* Modify files on the root filesystem. *)
- rewrite_fstab state devices_to_send;
+ rewrite_fstab config_devices_to_send;
(* XXX Other files to rewrite? *)
(* Unmount the root filesystem and sync disks. *)
sh "umount /mnt/root";
sh "sync"; (* Ugh, should be in stdlib. *)
- (* Get architecture of root filesystem, detected previously. *)
- let system_architecture =
- try
- (match List.assoc root_filesystem all_partitions with
- | LinuxRoot (arch, _) -> arch
- | _ -> raise Not_found
- )
- with
- Not_found ->
- (* None was detected before, so assume same as live CD. *)
+ (* 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
- match arch with
- | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
- | Some ("x86_64"::_) -> X86_64
- | Some ("ia64"::_) -> IA64
- | _ -> I386 (* probably wrong XXX *) in
-
- let remote_host = Option.get state.remote_host in
- let remote_port = Option.get state.remote_port in
- let remote_directory = Option.get state.remote_directory in
- let remote_username = Option.get state.remote_username in
-
- (* Functions to connect and disconnect from the remote system. *)
- let do_connect remote_name _ =
- let cmd = sprintf "ssh%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 chan = open_process_out cmd in
- descr_of_out_channel chan, chan
- in
- let do_disconnect (_, chan) =
- match close_process_out chan with
- | WEXITED 0 -> () (* OK *)
- | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
- | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
- | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
- in
+ let arch =
+ match arch with
+ | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
+ | Some ("x86_64"::_) -> X86_64
+ | Some ("ia64"::_) -> IA64
+ | _ -> I386 (* probably wrong XXX *) in
+ { config_target with tgt_architecture = arch }
+ | _ -> config_target in
(* XXX This is using the hostname derived from network configuration
* above. We might want to ask the user to choose.
"p2v-" ^ hostname ^ "-" ^ date in
(* Work out what the image filenames will be at the remote end. *)
- let devices_to_send = List.map (
+ 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)
- ) devices_to_send in
+ ) 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
*)
let conf_filename = basename ^ ".conf" in
- let architecture =
- match state.architecture with
- | Some UnknownArch | None -> system_architecture
- | Some arch -> arch in
- let memory =
- match state.memory with
- | Some 0 | None -> system_memory
- | Some memory -> memory in
- let vcpus =
- match state.vcpus with
- | Some 0 | None -> system_nr_cpus
- | Some n -> n in
- let mac_address =
- match state.mac_address with
- | Some "" | None -> random_mac_address ()
- | Some mac -> mac in
-
let xml =
(* Shortcut to make "<name>value</name>". *)
let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
(* Standard stuff for every domain. *)
let name = leaf "name" hostname in
let uuid = leaf "uuid" (random_uuid ()) in
- let maxmem = leaf "maxmem" (string_of_int (memory * 1024)) in
- let memory = leaf "memory" (string_of_int (memory * 1024)) in
- let vcpu = leaf "vcpu" (string_of_int vcpus) in
+ let maxmem, memory =
+ let m =
+ leaf "maxmem" (string_of_int (config_target.tgt_memory * 1024)) in
+ m, 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 =
- match state.hypervisor with
+ match config_target.tgt_hypervisor with
| Some Xen ->
[Xml.Element ("os", [],
[leaf "type" "hvm";
[Xml.Element ("os", [],
[Xml.Element ("type",
["arch",
- string_of_architecture architecture;
+ string_of_architecture
+ config_target.tgt_architecture;
"machine","pc"],
[Xml.PCData "hvm"]);
tleaf "boot" ["dev", "hd"]])]
(* <devices> section. *)
let devices =
let emulator =
- match state.hypervisor with
+ match config_target.tgt_hypervisor with
| Some Xen ->
[leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
| Some QEMU ->
[] in
let interface =
Xml.Element ("interface", ["type", "user"],
- [tleaf "mac" ["address", mac_address]]) in
+ [tleaf "mac" ["address",
+ config_target.tgt_mac_address]]) in
(* XXX should have an option for Xen bridging:
Xml.Element (
"interface", ["type","bridge"],
Xml.Element (
"disk", ["type", "file";
"device", "disk"],
- [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
+ [tleaf "source" ["file",
+ config_ssh.ssh_directory ^ "/" ^ remote_name];
tleaf "target" ["dev", remote_dev]]
)
- ) devices_to_send in
+ ) config_devices_to_send in
Xml.Element (
"devices", [],
(* Put it all together in <domain type='foo'>. *)
Xml.Element (
"domain",
- (match state.hypervisor with
+ (match config_target.tgt_hypervisor with
| Some Xen -> ["type", "xen"]
| Some QEMU -> ["type", "qemu"]
| Some KVM -> ["type", "kvm"]
let xml = Xml.to_string_fmt xml in
let conn_arg =
- match state.hypervisor with
+ match config_target.tgt_hypervisor with
| Some Xen | None -> ""
| Some QEMU | Some KVM -> " -c qemu:///system" in
let xml = sprintf "\
let xml_len = String.length xml in
eprintf "length of configuration file is %d bytes\n%!" xml_len;
- let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
+ 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);
- do_disconnect conn in
+ ssh_finish_upload conn in
(* Send the device snapshots to the remote host. *)
(* XXX This code should be made more robust against both network
let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
(* Now connect. *)
- let (sock,_) as conn = do_connect remote_name size in
+ let (sock,_) as conn = ssh_start_upload config_ssh remote_name in
(* Copy the data. *)
let spinners = "|/-\\" (* "Oo" *) in
printf "\n\n%!"; (* because of the messages printed above *)
(* Disconnect. *)
- do_disconnect conn
- ) devices_to_send;
+ ssh_finish_upload conn
+ ) config_devices_to_send;
(*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
(* Clean up and reboot. *)
ignore (
- msgbox (sprintf "%s completed" program_name)
+ message_box (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
+ config_ssh.ssh_directory conf_filename)
);
shfailok "eject";
shfailok "reboot";
-*)
+
exit 0
(*----------------------------------------------------------------------*)
git.annexia.org / virt-p2v.git / blobdiff