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