+ (* Network configuration. *)
+ let config_network =
+ match !config_network with
+ | Some n -> n
+ | None ->
+ open_centered_window ~stage:(s_ "Network")
+ 60 20 (s_ "Configure network");
+
+ let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in
+ Newt.listbox_set_width autolist 52;
+
+ (* Populate the "Automatic" listbox with RHEL/Fedora
+ * root partitions found which allow us to do
+ * automatic configuration in a known way.
+ *)
+ let rec loop = function
+ | [] -> ()
+ | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
+ :: parts ->
+ let label =
+ sprintf "%s (%s)"
+ (dev_of_partition partition)
+ (string_of_linux_distro distro) in
+ ignore (Newt.listbox_append_entry autolist label partition);
+ loop parts
+ | _ :: parts -> loop parts
+ in
+ loop all_partitions;
+
+ (* If there is no suitable root partition (the listbox
+ * is empty) then disable the auto option and the listbox.
+ *)
+ let no_auto = Newt.listbox_item_count autolist = 0 in
+
+ let auto =
+ Newt.radio_button 1 1
+ (s_ "Automatic from:") (not no_auto) None in
+ let shell =
+ Newt.radio_button 1 6
+ (s_ "Start a shell") no_auto (Some auto) in
+
+ if no_auto then (
+ Newt.component_takes_focus auto false;
+ Newt.component_takes_focus
+ (Newt.component_of_listbox autolist) false
+ );
+
+ let qemu =
+ Newt.radio_button 1 7
+ (s_ "QEMU user network") false (Some shell) in
+ let nonet =
+ Newt.radio_button 1 8
+ (s_ "Don't configure the network") false (Some qemu) in
+ let static =
+ Newt.radio_button 1 9
+ (s_ "Static configuration:") false (Some nonet) in
+
+ let label1 = Newt.label 4 10 (s_ "Interface") in
+ let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
+ let label2 = Newt.label 4 11 (s_ "IP") in
+ let entry2 = Newt.entry 16 11 None 16 [] in
+ let label3 = Newt.label 4 12 (s_ "Netmask") in
+ let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
+ let label4 = Newt.label 4 13 (s_ "Gateway") in
+ let entry4 = Newt.entry 16 13 None 16 [] in
+ let label5 = Newt.label 4 14 (s_ "Nameserver") in
+ let entry5 = Newt.entry 16 14 None 16 [] in
+
+ let enable_static () =
+ Newt.component_takes_focus entry1 true;
+ Newt.component_takes_focus entry2 true;
+ Newt.component_takes_focus entry3 true;
+ Newt.component_takes_focus entry4 true;
+ Newt.component_takes_focus entry5 true
+ in
+
+ let disable_static () =
+ Newt.component_takes_focus entry1 false;
+ Newt.component_takes_focus entry2 false;
+ Newt.component_takes_focus entry3 false;
+ Newt.component_takes_focus entry4 false;
+ Newt.component_takes_focus entry5 false
+ in
+
+ let enable_autolist () =
+ Newt.component_takes_focus
+ (Newt.component_of_listbox autolist) true
+ in
+ let disable_autolist () =
+ Newt.component_takes_focus
+ (Newt.component_of_listbox autolist) false
+ in
+
+ disable_static ();
+ Newt.component_add_callback auto
+ (fun () ->disable_static (); enable_autolist ());
+ Newt.component_add_callback shell
+ (fun () -> disable_static (); disable_autolist ());
+ Newt.component_add_callback qemu
+ (fun () -> disable_static (); disable_autolist ());
+ Newt.component_add_callback nonet
+ (fun () -> disable_static (); disable_autolist ());
+ Newt.component_add_callback static
+ (fun () -> enable_static (); disable_autolist ());
+
+ let ok = Newt.button 48 16 ok_button in
+
+ let form = Newt.form None None [] in
+ Newt.form_add_components form [auto;
+ Newt.component_of_listbox autolist;
+ shell;qemu;nonet;static;
+ label1;label2;label3;label4;label5;
+ entry1;entry2;entry3;entry4;entry5;
+ ok];
+
+ let n =
+ let rec loop () =
+ ignore (Newt.run_form form);
+
+ let r = Newt.radio_get_current auto in
+ if Newt.component_equals r auto then (
+ match Newt.listbox_get_current autolist with
+ | None -> loop ()
+ | Some part -> Auto part
+ )
+ else if Newt.component_equals r shell then Shell
+ else if Newt.component_equals r qemu then QEMUUserNet
+ else if Newt.component_equals r nonet then NoNetwork
+ else if Newt.component_equals r static then (
+ let interface = Newt.entry_get_value entry1 in
+ let address = Newt.entry_get_value entry2 in
+ let netmask = Newt.entry_get_value entry3 in
+ let gateway = Newt.entry_get_value entry4 in
+ let nameserver = Newt.entry_get_value entry5 in
+ if interface = "" || address = "" ||
+ netmask = "" || gateway = "" then
+ loop ()
+ else
+ Static (interface, address, netmask, gateway, nameserver)
+ )
+ else loop ()
+ in
+ loop () in
+ Newt.pop_window ();
+
+ n in
+
+ config_transfer_type, config_network
+ ) in
+
+ (* Try to bring up the network. *)
+ (match config_network with
+ | Shell ->
+ print_endline (s_ "Network configuration.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n");
+ shell ()
+
+ | Static (interface, address, netmask, gateway, nameserver) ->
+ print_endline (s_ "Trying static network configuration.\n");
+ if not (static_network
+ (interface, address, netmask, gateway, nameserver)) then (
+ print_endline (s_ "\nAuto-configuration failed. Starting a shell.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n");
+ shell ()
+ )
+
+ | Auto rootfs ->
+ print_endline
+ (s_ "Trying network auto-configuration from root filesystem ...\n");
+
+ (* Mount the root filesystem read-only under /mnt/root. *)
+ sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");
+
+ if not (auto_network ()) then (
+ print_endline (s_ "\nAuto-configuration failed. Starting a shell.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n");
+ shell ()
+ );
+
+ (* NB. Lazy unmount is required because dhclient keeps its current
+ * directory open on /etc/sysconfig/network-scripts/
+ *)
+ sh ("umount -l /mnt/root");
+
+ | QEMUUserNet ->
+ print_endline (s_ "Trying QEMU network configuration.\n");
+ qemu_network ()
+
+ | NoNetwork -> (* this is easy ... *) ()
+ );
+
+ (* SSH configuration phase. *)
+ let config_ssh =
+ with_newt (
+ fun () ->
+ match !config_ssh with
+ | Some c -> c
+ | None ->
+ (* Query the user for SSH configuration. *)
+ open_centered_window ~stage:(s_ "SSH configuration")
+ 60 20 (s_ "SSH configuration");
+
+ let label1 = Newt.label 1 1 (s_ "Remote host") in
+ let host = Newt.entry 20 1 None 36 [] in
+ let label2 = Newt.label 1 2 (s_ "Remote port") in
+ let port = Newt.entry 20 2 (Some "22") 6 [] in
+ let label3 = Newt.label 1 3 (s_ "Remote directory") in
+ let dir = Newt.entry 20 3 (Some "/var/lib/xen/images") 36 [] in
+ let label4 = Newt.label 1 4 (s_ "SSH username") in
+ let user = Newt.entry 20 4 (Some "root") 16 [] in
+ (*
+ There's no sensible way to support this for SSH:
+ let label5 = Newt.label 1 5 (s_ "SSH password") in
+ let pass = Newt.entry 20 5 None 16 [Newt.PASSWORD] in
+ *)
+
+ let compr =
+ Newt.checkbox 16 7 (s_ "Use SSH compression (not good for LANs)")
+ ' ' None in
+
+ let check =
+ Newt.checkbox 16 9 (s_ "Test SSH connection") '*' None in
+
+ let ok = Newt.button 48 16 ok_button in
+
+ let form = Newt.form None None [] in
+ Newt.form_add_components form [label1;label2;label3;label4;
+ host;port;dir;user;
+ compr;check;
+ ok];
+
+ let c =
+ let rec loop () =
+ ignore (Newt.run_form form);
+ let host = Newt.entry_get_value host in
+ let port = Newt.entry_get_value port in
+ let dir = Newt.entry_get_value dir in
+ let user = Newt.entry_get_value user in
+ let compr = Newt.checkbox_get_value compr = '*' in
+ let check = Newt.checkbox_get_value check = '*' in
+ if host <> "" && port <> "" && user <> "" then
+ { ssh_host = host; ssh_port = port; ssh_directory = dir;
+ ssh_username = user;
+ ssh_compression = compr;
+ ssh_check = check; }
+ else
+ loop ()
+ in
+ loop () in
+
+ Newt.pop_window ();
+ c
+ ) in
+
+ (* If asked, check the SSH connection. *)
+ if config_ssh.ssh_check then
+ if not (test_ssh config_ssh) then
+ failwith (s_ "SSH configuration failed");
+
+ (* Devices and root partition and target configuration selection stage. *)
+ let config_devices_to_send, config_root_filesystem, config_target =
+ with_newt (
+ fun () ->
+ let config_devices_to_send =
+ match !config_devices_to_send with
+ | Some ds -> ds
+ | None ->
+ let items = List.map (
+ fun (dev, size) ->
+ let label =
+ sprintf "/dev/%s (%.3f GB)" dev
+ ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in
+ (label, dev, true)
+ ) all_block_devices in
+
+ select_multiple ~stage:(s_ "Block devices")
+ ~force_one:true 60
+ (s_ "Select block devices to send")
+ items in
+
+ let config_root_filesystem =
+ match !config_root_filesystem with
+ | Some fs -> fs
+ | None ->
+ let items = List.map (
+ fun (part, nature) ->
+ let label =
+ sprintf "%s %s" (dev_of_partition part)
+ (string_of_nature nature) in
+ (label, part)
+ ) all_partitions in
+
+ select_single ~stage:(s_ "Root filesystem") 60
+ (s_ "Select root filesystem")
+ items in
+
+ let config_target =
+ match !config_target with
+ | Some t -> t
+ | None ->
+ open_centered_window ~stage:(s_ "Target system") 40 20
+ (s_ "Configure target system");
+
+ let hvlabel = Newt.label 1 1 (s_ "Hypervisor:") in
+ let hvlistbox = Newt.listbox 16 1 4 [Newt.SCROLL] in
+ Newt.listbox_append_entry hvlistbox "Xen" (Some Xen);
+ Newt.listbox_append_entry hvlistbox "QEMU" (Some QEMU);
+ Newt.listbox_append_entry hvlistbox "KVM" (Some KVM);
+ Newt.listbox_append_entry hvlistbox "Other" None;
+
+ let archlabel = Newt.label 1 5 (s_ "Architecture:") in
+ let archlistbox = Newt.listbox 16 5 4 [Newt.SCROLL] in
+ Newt.listbox_append_entry archlistbox "i386" I386;
+ Newt.listbox_append_entry archlistbox
+ "x86-64 (64-bit x86)" X86_64;
+ Newt.listbox_append_entry archlistbox "IA64 (Itanium)" IA64;
+ Newt.listbox_append_entry archlistbox "PowerPC 32-bit" PPC;
+ Newt.listbox_append_entry archlistbox "PowerPC 64-bit" PPC64;
+ Newt.listbox_append_entry archlistbox "SPARC 32-bit" SPARC;
+ Newt.listbox_append_entry archlistbox "SPARC 64-bit" SPARC64;
+ Newt.listbox_append_entry archlistbox "Unknown/other" UnknownArch;
+
+ (* Get the architecture of the selected root filesystem.
+ * If not known, default to UnknownArch.
+ *)
+ Newt.listbox_set_current_by_key archlistbox UnknownArch;
+ (try
+ match List.assoc config_root_filesystem all_partitions with
+ | LinuxRoot (arch, _) ->
+ Newt.listbox_set_current_by_key archlistbox arch
+ | _ -> ()
+ with
+ Not_found -> ());
+
+ let memlabel = Newt.label 1 9 (s_ "Memory (MB):") in
+ let mementry = Newt.entry 16 9
+ (Some (string_of_int system_memory)) 8 [] in
+ let cpulabel = Newt.label 1 10 (s_ "CPUs:") in
+ let cpuentry = Newt.entry 16 10
+ (Some (string_of_int system_nr_cpus)) 4 [] in
+ let maclabel = Newt.label 1 11 (s_ "MAC addr:") in
+ let macentry = Newt.entry 16 11 None 20 [] in
+ let maclabel2 =
+ Newt.label 1 12 (s_ "(leave MAC blank for random)") in
+
+ let libvirtd =
+ Newt.checkbox 12 14 (s_ "Use remote libvirtd") '*' None in
+
+ let ok = Newt.button 28 16 ok_button in
+
+ let form = Newt.form None None [] in
+ Newt.form_add_components form
+ [hvlabel; Newt.component_of_listbox hvlistbox;
+ archlabel; Newt.component_of_listbox archlistbox;
+ memlabel; mementry;
+ cpulabel; cpuentry;
+ maclabel; macentry; maclabel2;
+ libvirtd;
+ ok];
+
+ let c =
+ let rec loop () =
+ ignore (Newt.run_form form);
+ try
+ let hv = Newt.listbox_get_current hvlistbox in
+ let arch = Newt.listbox_get_current archlistbox in
+ let mem = int_of_string (Newt.entry_get_value mementry) in
+ let cpus = int_of_string (Newt.entry_get_value cpuentry) in
+ let mac = Newt.entry_get_value macentry in
+ let libvirtd = Newt.checkbox_get_value libvirtd = '*' in
+ if hv <> None && arch <> None && mem >= 0 && cpus >= 0
+ then
+ { tgt_hypervisor = Option.get hv;
+ tgt_architecture = Option.get arch;
+ tgt_memory = mem; tgt_vcpus = cpus;
+ tgt_mac_address =
+ if mac <> "" then mac else random_mac_address ();
+ tgt_libvirtd = libvirtd }
+ else
+ loop ()
+ with
+ Not_found | Failure "int_of_string" -> loop ()
+ in
+ loop () in
+
+ Newt.pop_window ();
+
+ c in
+
+ config_devices_to_send, config_root_filesystem, config_target
+ ) in
+
+ (* If architecture is set to UnknownArch, then assume the same
+ * architecture as the live CD.
+ *)
+ let config_target =
+ match config_target.tgt_architecture with
+ | UnknownArch ->
+ let arch = shget "uname -m" in
+ let arch =
+ match arch with
+ | Some (arch :: _) -> architecture_of_string arch
+ | _ -> I386 (* probably wrong XXX *) in
+ { config_target with tgt_architecture = arch }
+ | _ -> config_target in
+
+ (* Try to get the capabilities from the remote machine. If we fail
+ * it doesn't matter too much.
+ *)
+ let caps_os_type, caps_emulator, caps_loader, caps_machine =
+ try
+ if not config_target.tgt_libvirtd then raise Not_found;
+
+ let proto, path =
+ match config_target.tgt_hypervisor with
+ | Some Xen -> "xen", "/"
+ | Some (QEMU|KVM) -> "qemu", "/system"
+ | None -> raise Not_found in
+ let name =
+ sprintf "%s+ssh://%s@%s:%s%s"
+ proto config_ssh.ssh_username
+ config_ssh.ssh_host config_ssh.ssh_port path in
+ eprintf "capabilities URI = %S\n%!" name;
+
+ print_endline (s_ "Try to fetch remote hypervisor capabilities ...\n");
+
+ let conn = Libvirt.Connect.connect_readonly ~name () in
+ let caps = Libvirt.Connect.get_capabilities conn in
+ Libvirt.Connect.close conn;
+
+ (* Turn it into XML data. *)
+ let caps = Xml.parse_string caps in
+ eprintf "capabilities:\n%s\n%!" (Xml.to_string_fmt caps);
+
+ (* We're looking for a guest with <os_type>hvm</os_type>
+ * and <arch name="target-arch">... Later when we can
+ * install PV drivers automatically, we will want to look
+ * for paravirt guest types too.
+ *)
+ let guests = children_with_name "guest" caps in
+ let guests =
+ List.filter (xml_has_pcdata_child "os_type" "hvm") guests in
+ let arch_str = string_of_architecture config_target.tgt_architecture in
+ let guests =
+ List.filter (
+ xml_has_child_matching (
+ function
+ | Xml.Element (n, attribs, _)
+ when n = "arch"
+ && List.exists (
+ fun (n, a) ->
+ n = "name" &&
+ (* deal with i386 vs i686 pestilence *)
+ architecture_of_string a = config_target.tgt_architecture
+ ) attribs
+ -> true
+ | _ -> false
+ )
+ ) guests in
+
+ (* In theory at this point we only have a single guest type
+ * remaining. It might be that we have _zero_ available
+ * guest types, which indicates probably an unsupported
+ * capability of the remote hypervisor (or just that one of
+ * many parsing or heuristics failed). It might be that
+ * we have > 1 available guest types, which indicates some
+ * feature we don't know about.
+ *)
+ let len = List.length guests in
+ if len = 0 then (
+ message_box (s_ "Warning")
+ (sprintf (f_ "Remote hypervisor claims not to support fully virtualized %s guests.\n\nContinuing anyway.\n\n%!") arch_str);
+ raise Not_found
+ );
+
+ if len > 1 then (
+ message_box (s_ "Note")
+ (sprintf (f_ "Remote hypervisor supports multiple types of fully virtualized %s guests.\n\nPlease help further development of libvirt and virt-p2v by sending the file /tmp/virt-p2v.log back to the developers. See the main virt-p2v website for contact details.") arch_str)
+ );
+
+ let guest = List.hd guests in
+
+ let os_type =
+ try Some (find_pcdata_child "os_type" guest)
+ with Not_found -> None in
+ let arch_section = find_child_with_name "arch" guest in
+ let emulator =
+ try Some (find_pcdata_child "emulator" arch_section)
+ with Not_found -> None in
+ let loader =
+ try Some (find_pcdata_child "loader" arch_section)
+ with Not_found -> None in
+ let machine =
+ try Some (find_pcdata_child "machine" arch_section)
+ with Not_found -> None in
+
+ os_type, emulator, loader, machine
+ with
+ | Not_found -> None, None, None, None
+ | Xml.Error err ->
+ eprintf "XML error: %s\n%!" (Xml.error err);
+ None, None, None, None
+ | Xml.Not_element _ | Xml.Not_pcdata _ | Xml.No_attribute _ ->
+ (* If these occur, need to add some more debugging. *)
+ eprintf "XML error when parsing capabilities\n%!";
+ None, None, None, None
+ | Libvirt.Virterror err ->
+ eprintf "libvirt error: %s\n%!" (Libvirt.Virterror.to_string err);
+ None, None, None, None
+ | Invalid_argument str ->
+ eprintf "libvirt error: %s\n%!" str;
+ None, None, None, None in
+
+ (* In test mode, exit here before we do Bad Things to the developer's
+ * hard disk.
+ *)
+ if test_dialog_stages then exit 1;
+
+ print_endline (s_ "Performing LVM snapshots ...\n");
+
+ (* Switch LVM config. *)
+ sh "vgchange -a n";
+ putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
+ sh "rm -f /etc/lvm/cache/.cache";
+ sh "rm -f /etc/lvm.new/cache/.cache";
+
+ (* Snapshot the block devices to send. *)
+ let config_devices_to_send =
+ List.map (
+ fun origin_dev ->
+ let snapshot_dev = snapshot_name origin_dev in
+ snapshot origin_dev snapshot_dev;
+ (origin_dev, snapshot_dev)
+ ) config_devices_to_send in
+
+ (* Run kpartx on the snapshots. *)
+ List.iter (
+ fun (origin, snapshot) ->
+ shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
+ ) config_devices_to_send;
+
+ (* Rescan for LVs. *)
+ sh "vgscan";
+ sh "vgchange -a y";
+
+ (* Mount the root filesystem under /mnt/root. *)
+ (match config_root_filesystem with
+ | Part (dev, partnum) ->
+ let dev = dev ^ partnum in
+ let snapshot_dev = snapshot_name dev in
+ sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
+
+ | LV (vg, lv) ->
+ (* The LV will be backed by a snapshot device, so just mount
+ * directly.
+ *)
+ sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
+ );
+
+ (* Work out what devices will be called at the remote end. *)
+ let config_devices_to_send = List.map (
+ fun (origin_dev, snapshot_dev) ->
+ let remote_dev = remote_of_origin_dev origin_dev in
+ (origin_dev, snapshot_dev, remote_dev)
+ ) config_devices_to_send in
+
+ (* Modify files on the root filesystem. *)
+ rewrite_fstab config_devices_to_send;
+ (* XXX Other files to rewrite? *)
+
+ (* Unmount the root filesystem and sync disks. *)
+ sh "umount /mnt/root";
+ sh "sync"; (* Ugh, should be in stdlib. *)
+
+ (* XXX This is using the hostname derived from network configuration
+ * above. We might want to ask the user to choose.
+ *)
+ let hostname = safe_name (gethostname ()) in
+ let basename =
+ let date = sprintf "%04d%02d%02d%02d%02d"
+ (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
+ "p2v-" ^ hostname ^ "-" ^ date in
+
+ (* Work out what the image filenames will be at the remote end. *)
+ let config_devices_to_send = List.map (
+ fun (origin_dev, snapshot_dev, remote_dev) ->
+ let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
+ (origin_dev, snapshot_dev, remote_dev, remote_name)
+ ) config_devices_to_send in
+
+ (* Write a configuration file. Not sure if this is any better than
+ * just 'sprintf-ing' bits of XML text together, but at least we will
+ * always get well-formed XML.
+ *
+ * XXX There is a case for using virt-install to generate this XML.
+ * When we start to incorporate libvirt access & storage API this
+ * needs to be rethought.
+ *)
+ let conf_filename = basename ^ ".conf" in
+
+ let xml =
+ (* Shortcut to make "<name>value</name>". *)
+ let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
+ (* ... and the _other_ sort of leaf (god I hate XML). *)
+ let tleaf name attribs = Xml.Element (name, attribs, []) in
+
+ let arch_str =
+ string_of_architecture config_target.tgt_architecture in
+ let arch_wordsize =
+ wordsize_of_architecture config_target.tgt_architecture in
+
+ (* Standard stuff for every domain. *)
+ let name = leaf "name" hostname in
+ let uuid = leaf "uuid" (random_uuid ()) in
+ let maxmem, memory =
+ let m = string_of_int (config_target.tgt_memory * 1024) in
+ leaf "maxmem" m, leaf "memory" m in
+ let vcpu = leaf "vcpu" (string_of_int config_target.tgt_vcpus) in
+
+ (* Top-level stuff which differs for each HV type (isn't this supposed
+ * to be portable ...)
+ *)
+ let extras =
+ (* Use capabilities for os_type, etc. else use some good guesses. *)
+ let os_type = Option.default "hvm" caps_os_type in
+ let machine = Option.default "pc" caps_machine in
+ let loader = Option.default "/usr/lib/xen/boot/hvmloader" caps_loader in
+
+ match config_target.tgt_hypervisor with
+ | Some Xen ->
+ [Xml.Element ("os", [],
+ [leaf "type" os_type;
+ leaf "loader" loader;
+ tleaf "boot" ["dev", "hd"]]);
+ Xml.Element ("features", [],
+ [tleaf "pae" [];
+ tleaf "acpi" [];
+ tleaf "apic" []]);
+ tleaf "clock" ["sync", "localtime"]]
+ | Some KVM ->
+ [Xml.Element ("os", [], [leaf "type" os_type]);
+ tleaf "clock" ["sync", "localtime"]]
+ | Some QEMU ->
+ [Xml.Element ("os", [],
+ [Xml.Element ("type",
+ ["arch", arch_str;
+ "machine", machine],
+ [Xml.PCData os_type]);
+ tleaf "boot" ["dev", "hd"]])]
+ | None ->
+ [] in
+
+ (* <devices> section. *)
+ let devices =
+ let emulator =
+ match caps_emulator with
+ (* Use the emulator from the libvirt capabilities. *)
+ | Some s -> [leaf "emulator" s]
+ | None ->
+ (* If we don't have libvirt capabilities, best guess. *)
+ match config_target.tgt_hypervisor with
+ | Some Xen ->
+ [leaf "emulator"
+ (if arch_wordsize = W64 then "/usr/lib64/xen/bin/qemu-dm"
+ else "/usr/lib/xen/bin/qemu-dm")]
+ | Some QEMU ->
+ [leaf "emulator" "/usr/bin/qemu"]
+ | Some KVM ->
+ [leaf "emulator" "/usr/bin/qemu-kvm"]
+ | None ->
+ [] in
+ let interface =
+ Xml.Element ("interface", ["type", "user"],
+ [tleaf "mac" ["address",
+ config_target.tgt_mac_address]]) in
+ (* XXX should have an option for Xen bridging:
+ Xml.Element (
+ "interface", ["type","bridge"],
+ [tleaf "source" ["bridge","xenbr0"];
+ tleaf "mac" ["address",mac_address];
+ tleaf "script" ["path","vif-bridge"]])*)
+ let graphics = tleaf "graphics" ["type", "vnc"] in
+
+ let disks = List.map (
+ fun (_, _, remote_dev, remote_name) ->
+ Xml.Element (
+ "disk", ["type", "file";
+ "device", "disk"],
+ [tleaf "source" ["file",
+ config_ssh.ssh_directory ^ "/" ^ remote_name];
+ tleaf "target" ["dev", remote_dev]]
+ )
+ ) config_devices_to_send in
+
+ Xml.Element (
+ "devices", [],
+ emulator @ interface :: graphics :: disks
+ ) in
+
+ (* Put it all together in <domain type='foo'>. *)
+ Xml.Element (
+ "domain",
+ (match config_target.tgt_hypervisor with
+ | Some Xen -> ["type", "xen"]
+ | Some QEMU -> ["type", "qemu"]
+ | Some KVM -> ["type", "kvm"]
+ | None -> []),
+ name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
+ ) in
+
+ (* Convert XML configuration file to a string, then send it to the
+ * remote server.
+ *)
+ let () =
+ let xml = Xml.to_string_fmt xml in
+
+ let conn_arg =
+ match config_target.tgt_hypervisor with
+ | Some Xen | None -> ""
+ | Some QEMU | Some KVM -> " -c qemu:///system" in
+ let xml = sprintf (f_ "\
+<!--
+ This is an automatically generated libvirt configuration file.
+ It was written by the %s program.
+
+ Please check the values in this configuration file carefully,
+ particularly maxmem, memory, vcpu and any paths.
+
+ To start the domain, do:
+ virsh%s define %s
+ virsh%s start %s
+-->\n\n") program_name conn_arg conf_filename conn_arg hostname
+ ^ xml
+ ^ "\n" in
+
+ let xml_len = String.length xml in
+ eprintf "length of configuration file is %d bytes\n%!" xml_len;
+
+ print_endline (s_ "\nWriting configuration file ...\n");
+
+ let (sock,_) as conn = ssh_start_upload config_ssh conf_filename in
+ (* In OCaml this actually loops calling write(2) *)
+ ignore (write sock xml 0 xml_len);
+ ssh_finish_upload conn in
+
+ (* Send the device snapshots to the remote host. *)
+ (* XXX This code should be made more robust against both network
+ * errors and local I/O errors. Also should allow the user several
+ * attempts to connect, or let them go back to the dialog stage.
+ *)
+ List.iter (
+ fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
+ eprintf "sending %s as %s\n%!" origin_dev remote_name;
+
+ let size =
+ try List.assoc origin_dev all_block_devices
+ with Not_found -> assert false (* internal error *) in
+
+ let () =
+ printf (f_ "\nSending /dev/%s (%.3f GB) to remote machine\n\n%!")
+ origin_dev ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in
+
+ (* Open the snapshot device. *)
+ let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
+
+ (* Now connect. *)
+ let (sock,_) as conn = ssh_start_upload config_ssh remote_name in
+
+ (* Copy the data. *)
+ let spinners = "|/-\\" (* "Oo" *) in
+ let bufsize = 1024 * 1024 in
+ let buffer = String.create bufsize in
+ let start = gettimeofday () in
+
+ let rec copy bytes_sent last_printed_at spinner =
+ let n = read fd buffer 0 bufsize in
+ if n > 0 then (
+ let n' = write sock buffer 0 n in
+ if n <> n' then assert false; (* never, according to the manual *)
+
+ let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
+ let last_printed_at, spinner =
+ let now = gettimeofday () in
+ (* Print progress every few seconds. *)
+ if now -. last_printed_at > 2. then (
+ let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
+ let secs_elapsed = now -. start in
+ printf "%.0f%% %c %.1f Mbps"
+ (100. *. elapsed) spinners.[spinner]
+ (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
+ (* After 60 seconds has elapsed, start printing estimates. *)
+ if secs_elapsed >= 60. then (
+ let remaining = 1. -. elapsed in
+ let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
+ if secs_remaining > 120. then
+ printf (f_ " (about %.0f minutes remaining)")
+ (secs_remaining/.60.)
+ else
+ printf (f_ " (about %.0f seconds remaining)")
+ secs_remaining
+ );
+ printf " \r%!";
+ let spinner = (spinner + 1) mod String.length spinners in
+ now, spinner
+ )
+ else last_printed_at, spinner in
+
+ copy bytes_sent last_printed_at spinner
+ )
+ in
+ copy 0L start 0;
+ printf "\n\n%!"; (* because of the messages printed above *)
+
+ (* Disconnect. *)
+ ssh_finish_upload conn
+ ) config_devices_to_send;
+
+ (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
+
+ (* Clean up and reboot. *)
+ ignore (
+ message_box (sprintf (f_ "%s has finished") program_name)
+ (sprintf (f_ "\nThe physical to virtual migration is complete.\n\nPlease verify the disk image(s) and configuration file on the remote host, and then start up the virtual machine by doing:\n\ncd %s\nvirsh define %s\n\nWhen you press [OK] this machine will reboot.")
+ config_ssh.ssh_directory conf_filename)
+ );
+
+ shfailok "eject";
+ shfailok "reboot";
+
+ exit 0
+
+(*----------------------------------------------------------------------*)