1 #!/usr/bin/ocamlrun /usr/bin/ocaml
3 (* virt-p2v is a script which performs a physical to
4 * virtual conversion of local disks.
6 * Copyright (C) 2007-2008 Red Hat Inc.
7 * Written by Richard W.M. Jones <rjones@redhat.com>
9 * This program is free software; you can redistribute it and/or modify
10 * it under the terms of the GNU General Public License as published by
11 * the Free Software Foundation; either version 2 of the License, or
12 * (at your option) any later version.
14 * This program is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
19 * You should have received a copy of the GNU General Public License
20 * along with this program; if not, write to the Free Software
21 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
25 | Part of string * string (* eg. "hda", "1" *)
26 | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
28 | P2V (* physical to virtual *)
29 | V2V (* virtual to virtual *)
30 (*| V2P*) (* virtual to physical - not impl *)
32 | Auto of partition (* Automatic network configuration. *)
33 | Shell (* Start a shell. *)
34 | QEMUUserNet (* Assume we're running under qemu. *)
35 | Static of string * string * string * string * string
36 (* interface, address, netmask, gateway, nameserver *)
39 ssh_host : string; (* Remote host for SSH. *)
40 ssh_port : string; (* Remote port. *)
41 ssh_directory : string; (* Remote directory. *)
42 ssh_username : string; (* Remote username. *)
43 ssh_compression : bool; (* If true, use SSH compression. *)
44 ssh_check : bool; (* If true, check SSH is working. *)
51 | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
55 | W32 | W64 | WUnknown
56 type target_config = {
57 tgt_hypervisor : hypervisor option; (* Remote hypervisor. *)
58 tgt_architecture : architecture; (* Remote architecture. *)
59 tgt_memory : int; (* Memory (megabytes). *)
60 tgt_vcpus : int; (* Number of virtual CPUs. *)
61 tgt_mac_address : string; (* MAC address. *)
62 tgt_libvirtd : bool; (* True if libvirtd on remote. *)
65 (*----------------------------------------------------------------------*)
66 (* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section.
68 * If left as they are, then this will create a generic virt-p2v script
69 * which asks the user for each question. If you set the defaults here
70 * then you will get a custom virt-p2v which is partially or even fully
71 * automated and won't ask the user any questions.
73 * Note that 'None' means 'no default' (ie. ask the user) whereas
74 * 'Some foo' means use 'foo' as the answer.
76 * These are documented in the virt-p2v(1) manual page.
78 * After changing them, run './virt-p2v --test' to check syntax.
81 (* If greeting is true, wait for keypress after boot and during
82 * final verification. Set to 'false' for less interactions.
84 let config_greeting = ref true
86 (* General type of transfer. *)
87 let config_transfer_type = ref None
89 (* Network configuration. *)
90 let config_network = ref None
92 (* SSH configuration. *)
93 let config_ssh = ref None
95 (* What to transfer. *)
96 let config_devices_to_send = ref None
97 let config_root_filesystem = ref None
99 (* Configuration of the target. *)
100 let config_target = ref None
102 (* The name of the program as displayed in various places. *)
103 let program_name = "virt-p2v"
105 (* If you want to test the dialog stages, set this to true. *)
106 let test_dialog_stages = false
108 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
109 (*----------------------------------------------------------------------*)
111 (* Load external libraries. *)
117 #require "xml-light";;
118 #require "gettext-stub";;
126 (*----------------------------------------------------------------------*)
129 * Use s_ "string" to mark a translatable string, and f_ "string %s"
130 * to mark a format string (eg. for printf). There are other
131 * functions: see ocaml-gettext manual and GNU gettext info.
133 * Try not to mark strings which always go to the log file (eg.
137 module P2VGettext = Gettext.Program (
139 let textdomain = "virt-p2v"
142 let dependencies = []
144 ) (GettextStub.Native)
147 (*----------------------------------------------------------------------*)
148 (* General helper functions. *)
150 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
151 let xs = List.sort ~cmp xs in
152 let rec loop = function
153 | [] -> [] | [x] -> [x]
154 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
155 | x :: xs -> x :: loop xs
159 let input_all_lines chan =
160 let lines = ref [] in
162 while true do lines := input_line chan :: !lines done; []
164 End_of_file -> List.rev !lines
166 let dev_of_partition = function
167 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
168 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
170 let string_of_architecture = function
177 | SPARC64 -> "sparc64"
178 | OtherArch arch -> arch
181 let architecture_of_string = function
183 String.length str = 4 &&
184 (str.[0] = 'i' || str.[0] = 'I') &&
185 (str.[1] >= '3' && str.[1] <= '6') &&
186 str.[2] = '8' && str.[3] = '6' -> I386
187 | "x86_64" | "X86_64" | "x86-64" | "X86-64" -> X86_64
188 | "ia64" | "IA64" -> IA64
189 | "ppc" | "PPC" | "ppc32" | "PPC32" -> PPC
190 | "ppc64" | "PPC64" -> PPC64
191 | "sparc" | "SPARC" | "sparc32" | "SPARC32" -> SPARC
192 | "sparc64" | "SPARC64" -> SPARC64
194 | str -> OtherArch str
196 let wordsize_of_architecture = function
204 | OtherArch arch -> WUnknown
205 | UnknownArch -> WUnknown
207 type nature = LinuxSwap
208 | LinuxRoot of architecture * linux_distro
209 | WindowsRoot (* Windows C: *)
210 | LinuxBoot (* Linux /boot *)
211 | NotRoot (* mountable, but not / or /boot *)
213 and linux_distro = RHEL of int * int
215 | Debian of int * int
218 let rec string_of_nature = function
219 | LinuxSwap -> s_ "Linux swap"
220 | LinuxRoot (architecture, distro) ->
221 string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
222 | WindowsRoot -> s_ "Windows root"
223 | LinuxBoot -> s_ "Linux /boot"
224 | NotRoot -> s_ "Mountable non-root"
225 | UnknownNature -> s_ "Unknown partition type"
226 and string_of_linux_distro = function
227 | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
228 | Fedora v -> sprintf "Fedora %d" v
229 | Debian (a,b) -> sprintf "Debian %d.%d" a b
230 | OtherLinux -> "Linux"
232 (* XML helper functions. *)
233 let rec children_with_name name xml =
234 let children = Xml.children xml in
237 | Xml.Element (n, _, _) when n = name -> true
240 and xml_has_pcdata_child name pcdata xml =
241 xml_has_child_matching (
243 | Xml.Element (n, _, [Xml.PCData pcd])
244 when n = name && pcd = pcdata -> true
247 and xml_has_attrib_child name attrib xml =
248 xml_has_child_matching (
250 | Xml.Element (n, attribs, _)
251 when n = name && List.mem attrib attribs -> true
254 and xml_has_child_matching f xml =
255 let children = Xml.children xml in
256 List.exists f children
257 and find_child_with_name name xml =
258 let children = children_with_name name xml in
260 | [] -> raise Not_found
262 and find_pcdata_child name xml =
263 let children = children_with_name name xml in
264 let rec loop = function
265 | [] -> raise Not_found
266 | Xml.Element (_, _, [Xml.PCData pcd]) :: _ -> pcd
271 type ('a, 'b) either = Either of 'a | Or of 'b
273 (* We go into and out of newt mode at various stages, but we might
274 * also need to put up a message at any time. This keeps track of
275 * whether we are in newt mode or not.
277 * General tip: Try to do any complex operations like setting up the
278 * network or probing disks outside newt mode, and try not to throw
279 * exceptions in newt mode.
281 let in_newt = ref false
283 if !in_newt then f ()
287 try Either (Newt.init_and_finish f)
288 with exn -> Or exn in
290 match r with Either r -> r | Or exn -> raise exn
293 (* Clear the screen, open a new centered window, make sure the background
294 * and help messages are consistent.
296 let open_centered_window ?stage width height title =
297 if not !in_newt then failwith (s_ "open_centered_window: not in newt mode");
299 Newt.centered_window width height title;
301 program_name ^ (match stage with
303 | Some stage -> " - " ^ stage) in
304 Newt.draw_root_text 0 0 root_text;
306 (s_ "F12 for next screen | [ALT] [F2] root / no password for shell")
308 let ok_button = " OK "
310 (* Some general dialog boxes. *)
311 let message_box title text =
314 open_centered_window 40 20 title;
316 let textbox = Newt.textbox 1 1 36 14 [Newt.WRAP; Newt.SCROLL] in
317 Newt.textbox_set_text textbox text;
318 let ok = Newt.button 28 16 ok_button in
319 let form = Newt.form None None [] in
320 Newt.form_add_components form [textbox; ok];
322 Newt.component_takes_focus ok true;
324 ignore (Newt.run_form form);
328 (* Fail and exit with error. *)
333 ^ s_ "\n\nIf you want to report this error, there is a shell on [ALT] [F2], log in as root with no password.\n\nPlease provide the contents of /tmp/virt-p2v.log and output of the 'dmesg' command." in
334 message_box (s_ "Error") text;
337 (* Display a dialog with checkboxes, return the multiple selected items. *)
338 let select_multiple ?stage ?(force_one = false) width title items =
341 open_centered_window ?stage width 20 title;
345 fun i (label, handle, selected) ->
347 Newt.checkbox 1 (i+1) label
348 (if selected then '*' else ' ') None in
352 let ok = Newt.button 48 16 ok_button in
355 if List.length entries > 10 then
356 Some (Newt.vertical_scrollbar 58 1 10
357 Newt_int.NEWT_COLORSET_WINDOW
358 Newt_int.NEWT_COLORSET_ACTCHECKBOX)
361 let form = Newt.form vb None [] in
362 Newt.form_add_components form (List.map snd entries);
363 Newt.form_add_component form ok;
367 ignore (Newt.run_form form);
368 let selected = List.filter_map (
370 if Newt.checkbox_get_value cb = '*' then Some handle else None
372 if force_one && selected = [] then loop ()
382 (* Display a dialog with radio buttons, return the single selected item. *)
383 let select_single ?stage width title items =
384 if items = [] then failwith "select_single: no items";
388 open_centered_window ?stage width 20 title;
390 let prev = ref None in
393 fun i (label, handle) ->
394 let rb = Newt.radio_button 1 (i+1) label (!prev = None) !prev in
399 let ok = Newt.button (width-12) 16 ok_button in
402 if List.length entries > 10 then
403 Some (Newt.vertical_scrollbar 58 1 10
404 Newt_int.NEWT_COLORSET_WINDOW
405 Newt_int.NEWT_COLORSET_ACTCHECKBOX)
408 let form = Newt.form vb None [] in
409 Newt.form_add_components form (List.map snd entries);
410 Newt.form_add_component form ok;
414 ignore (Newt.run_form form);
415 let r = Option.get !prev in
416 let r = Newt.radio_get_current r in
417 (* Now we compare 'r' to all the 'rb's in the list
418 * to see which one is selected.
421 List.find (fun (_, rb) -> Newt.component_equals r rb) entries
432 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
433 let quote = Filename.quote
435 (* Run a shell command and check it returns 0. *)
437 eprintf "sh: %s\n%!" cmd;
438 if Sys.command cmd <> 0 then
439 failwith (sprintf (f_ "Command failed:\n\n%s") cmd)
442 eprintf "shfailok: %s\n%!" cmd;
443 ignore (Sys.command cmd)
445 let shwithstatus cmd =
446 eprintf "shwithstatus: %s\n%!" cmd;
449 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
451 eprintf "shget: %s\n%!" cmd;
452 let chan = open_process_in cmd in
453 let lines = input_all_lines chan in
454 match close_process_in chan with
455 | WEXITED 0 -> Some lines (* command succeeded *)
456 | WEXITED _ -> None (* command failed *)
458 failwith (sprintf (f_ "shget: command killed by signal %d") i)
460 failwith (sprintf (f_ "shget: command stopped by signal %d") i)
462 (* Start an interactive shell. Need to juggle file descriptors a bit
463 * because bash write PS1 to stderr (currently directed to the logfile).
467 | 0 -> (* child, runs bash *)
470 (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
472 Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
474 | _ -> (* parent, waits *)
475 eprintf "waiting for subshell to exit\n%!";
478 (* Some true if is dir/file, Some false if not, None if not found. *)
480 try Some ((stat path).st_kind = S_DIR)
481 with Unix_error (ENOENT, "stat", _) -> None
483 try Some ((stat path).st_kind = S_REG)
484 with Unix_error (ENOENT, "stat", _) -> None
486 (*----------------------------------------------------------------------*)
487 (* P2V-specific helper functions. *)
489 (* Generate a predictable safe name containing only letters, numbers
490 * and underscores. If passed a string with no letters or numbers,
491 * generates "_1", "_2", etc.
496 fun () -> incr i; "_" ^ string_of_int !i
499 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
500 let name = String.copy name in
501 let have_safe = ref false in
502 for i = 0 to String.length name - 1 do
503 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
505 if !have_safe then name else next_anon ()
507 type block_device = string * int64 (* "hda" & size in bytes *)
509 (* Parse the output of 'lvs' to get list of LV names, sizes,
510 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
513 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
517 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
521 let lines = List.map Pcre.split lines in
524 | [vg; lv; pvs; lvsize]
525 | [_; vg; lv; pvs; lvsize] ->
526 let pvs = String.nsplit pvs "," in
527 let pvs = List.filter_map (
530 let subs = Pcre.exec ~rex:devname pv in
531 Some (Pcre.get_substring subs 1)
534 eprintf "lvs: unexpected device name: %s\n%!" pv;
537 LV (vg, lv), pvs, lvsize
539 failwith ("lvs: " ^ s_ "unexpected output: " ^
540 String.concat "," line)
543 (* Get the partitions on a block device.
544 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
546 let get_partitions dev =
547 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
548 let devdir = "/sys/block/" ^ dev in
549 let parts = Sys.readdir devdir in
550 let parts = Array.to_list parts in
551 let parts = List.filter (
552 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
554 let parts = List.filter_map (
557 let subs = Pcre.exec ~rex part in
558 Some (Part (dev, Pcre.get_substring subs 1))
564 (* Generate snapshot device name from device name. *)
565 let snapshot_name dev =
566 "snap" ^ (safe_name dev)
568 (* Perform a device-mapper snapshot with ramdisk overlay. *)
570 let next_free_ram_disk =
572 fun () -> incr i; "/dev/ram" ^ string_of_int !i
574 fun origin_dev snapshot_dev ->
575 let ramdisk = next_free_ram_disk () in
577 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
578 let lines = shget cmd in
580 | Some (sectors::_) -> Int64.of_string sectors
582 failwith (sprintf (f_ "Disk snapshot failed: unable to read the size in sectors of block device %s") origin_dev) in
584 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
585 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
586 snapshot_dev sectors origin_dev);
587 (* Create the snapshot. *)
588 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
589 snapshot_dev sectors snapshot_dev ramdisk)
591 (* Try to perform automatic network configuration, assuming a Fedora or
592 * RHEL-like root filesystem mounted on /mnt/root.
594 let auto_network () =
595 (* Fedora gives an error if this file doesn't exist. *)
596 sh "touch /etc/resolv.conf";
598 (* NB. Lazy unmount is required because dhclient keeps its current
599 * directory open on /etc/sysconfig/network-scripts/
600 * (Fixed in dhcp >= 4.0.0 but be generous anyway).
602 sh "mount -o bind /mnt/root/etc /etc";
603 let status = shwithstatus "/etc/init.d/network start" in
606 (* Try to ping the default gateway to see if this worked. *)
607 shfailok "ping -c3 `/sbin/ip route list match 0.0.0.0 | head -1 | awk '{print $3}'`";
609 if !config_greeting then (
610 print_endline (s_ "\n\nDid automatic network configuration work?\nHint: If not sure, there is a shell on console [ALT] [F2]");
612 let line = read_line () in
613 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
616 (* Non-interactive: return the status of /etc/init.d/network start. *)
619 (* Configure the network statically. *)
620 let static_network (interface, address, netmask, gateway, nameserver) =
621 let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
623 do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
624 (quote interface) (quote address) (quote netmask));
625 do_cmd_or_exit (sprintf "route add default gw %s %s"
626 (quote gateway) (quote interface));
627 if nameserver <> "" then
628 do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
632 Exit -> false (* failed *)
634 (* http://fabrice.bellard.free.fr/qemu/qemu-doc.html#SEC30 *)
635 let qemu_network () =
636 sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0";
637 sh "route add default gw 10.0.2.2 eth0";
638 sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"
640 (* Map local device names to remote devices names. At the moment we
641 * just change sd* to hd* (as device names appear under fullvirt). In
642 * future, lots of complex possibilities.
644 let remote_of_origin_dev =
645 let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
646 let devsd_subst = Pcre.subst "hd$1" in
648 Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
650 (* Make an SSH connection to the remote machine, execute command.
651 * The connection remains open until you call ssh_disconnect, it
652 * times out or there is some error.
654 * NB. The command is NOT quoted.
656 * Returns a pair (file descriptor, channel), both referring to the
657 * same thing. Use whichever is more convenient.
659 let ssh_connect config cmd =
660 let cmd = sprintf "ssh%s -l %s -p %s %s %s"
661 (if config.ssh_compression then " -C" else "")
662 (quote config.ssh_username) (quote config.ssh_port) (quote config.ssh_host)
664 eprintf "ssh_connect: %s\n%!" cmd;
665 let chan = open_process_out cmd in
666 descr_of_out_channel chan, chan
668 let ssh_disconnect (_, chan) =
669 eprintf "ssh_disconnect\n%!";
670 match close_process_out chan with
671 | WEXITED 0 -> () (* OK *)
672 | WEXITED i -> failwith (sprintf (f_ "ssh: exited with error code %d") i)
673 | WSIGNALED i -> failwith (sprintf (f_ "ssh: killed by signal %d") i)
674 | WSTOPPED i -> failwith (sprintf (f_ "ssh: stopped by signal %d") i)
676 (* Use these functions to upload a file. *)
677 let ssh_start_upload config filename =
679 sprintf "cat \\> %s/%s" (quote config.ssh_directory) (quote filename) in
680 ssh_connect config cmd
682 let ssh_finish_upload = ssh_disconnect
684 (* Test SSH connection. *)
685 let test_ssh config =
687 (s_ "Testing SSH connection by listing files in remote directory ...\n");
689 let cmd = sprintf "/bin/ls %s" (quote config.ssh_directory) in
690 let conn = ssh_connect config cmd in
693 if !config_greeting then (
694 print_endline (s_ "\n\nDid SSH work?\nHint: If not sure, there is a shell on console [ALT] [F2]\n");
696 let line = read_line () in
697 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
702 (* Rewrite /mnt/root/etc/fstab. *)
703 let rewrite_fstab devices_to_send =
704 let filename = "/mnt/root/etc/fstab" in
705 if is_file filename = Some true then (
706 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
708 let chan = open_in filename in
709 let lines = input_all_lines chan in
711 let lines = List.map Pcre.split lines in
712 let lines = List.map (
714 | dev :: rest when String.starts_with dev "/dev/" ->
715 let dev = String.sub dev 5 (String.length dev - 5) in
716 let dev = remote_of_origin_dev dev in
717 let dev = "/dev/" ^ dev in
722 let chan = open_out filename in
725 | [dev; mountpoint; fstype; options; freq; passno] ->
726 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
727 dev mountpoint fstype options freq passno
729 output_string chan (String.concat " " line);
730 output_char chan '\n'
735 (* Generate a random MAC address in the Xen-reserved space. *)
736 let random_mac_address () =
738 List.map (sprintf "%02x") (
739 List.map (fun _ -> Random.int 256) [0;0;0]
741 String.concat ":" ("00"::"16"::"3e"::random)
743 (* Generate a random UUID. *)
745 let hex = "0123456789abcdef" in
747 let str = String.create 32 in
748 for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
751 (*----------------------------------------------------------------------*)
752 (* Main entry point. *)
754 (* The general plan for the main function is to operate in stages:
759 * Information gathering about the system
760 * | (eg. block devices, number of CPUs, etc.)
762 * Greeting and type of transfer question
766 * | (after this point we have a working network)
769 * | (after this point we have a working SSH connection)
771 * Questions about what to transfer (block devs, root fs) <--.
774 * Questions about hypervisor configuration |
777 * Verify information -------- user wants to change info ----/
782 * Prior versions of virt-p2v (the ones which used 'dialog') had support
783 * for a back button so they could go back through dialogs. I removed
784 * this because it was hard to support and not particularly useful.
787 let rec main ttyname =
790 (* Running from an init script. We don't have much of a
791 * login environment, so set one up.
795 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
796 "/usr/bin"; "/bin"]);
797 putenv "HOME" "/root";
798 putenv "LOGNAME" "root";
800 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
803 (* Set up logging to /tmp/virt-p2v.log. *)
804 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
808 (* Log the start up time. *)
809 eprintf "\n\n**************************************************\n\n";
810 let tm = localtime (time ()) in
811 eprintf "%s starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
813 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
815 (* Connect stdin/stdout to the tty. *)
819 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
825 (* Choose language early, so messages are translated. *)
826 if !config_greeting then (
829 (* Note these strings are NOT translated! *)
831 "English", "en_US.UTF-8";
832 "\xE6\x97\xA5\xE6\x9C\xAC\xE8\xAA\x9E (Japanese)", "ja_JP.UTF-8"
835 let lang = select_single ~stage:(s_ "Select language") 40
836 (s_ "Select language")
840 ignore (GettextStubCompat.setlocale GettextStubCompat.LC_ALL lang)
844 let () = printf (f_ "%s starting up ...\n%!") program_name in
846 (* Disable screen blanking on tty. *)
847 sh "setterm -blank 0";
849 (* Check that the environment is a sane-looking live CD. If not, bail. *)
850 if not test_dialog_stages && is_dir "/mnt/root" <> Some true then
852 (s_ "You should only run this script from the live CD or a USB key.");
854 (* Start of the information gathering phase. *)
856 (s_ "Detecting hard drives (this may take some time) ...");
858 (* Search for all non-removable block devices. Do this early and bail
859 * if we can't find anything. This is a list of strings, like "hda".
861 let all_block_devices : block_device list =
862 let rex = Pcre.regexp "^[hs]d" in
863 let devices = Array.to_list (Sys.readdir "/sys/block") in
864 let devices = List.sort devices in
865 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
866 eprintf "all_block_devices: block devices: %s\n%!"
867 (String.concat "; " devices);
868 (* Run blockdev --getsize64 on each, and reject any where this fails
869 * (probably removable devices).
871 let devices = List.filter_map (
873 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
874 let lines = shget cmd in
876 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
877 | Some [] | None -> None
879 eprintf "all_block_devices: non-removable block devices: %s\n%!"
881 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
884 (s_ "No non-removable block devices (hard disks, etc.) could be found on this machine.");
887 (* Search for partitions and LVs (anything that could contain a
888 * filesystem directly). We refer to these generically as
891 let all_partitions : partition list =
894 let lvs = get_lvs () in
895 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
896 let pvs = List.concat pvs in
897 let pvs = sort_uniq pvs in
898 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
899 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
900 eprintf "all_partitions: LVs: %s\n%!"
901 (String.concat "; " (List.map dev_of_partition lvs));
904 (* Partitions (eg. "sda1", "sda2"). *)
906 let parts = List.map fst all_block_devices in
907 let parts = List.map get_partitions parts in
908 let parts = List.concat parts in
909 eprintf "all_partitions: all partitions: %s\n%!"
910 (String.concat "; " (List.map dev_of_partition parts));
912 (* Remove any partitions which are PVs. *)
913 let parts = List.filter (
915 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
916 | LV _ -> assert false
919 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
920 (String.concat "; " (List.map dev_of_partition parts));
922 (* Concatenate LVs & Parts *)
925 (* Try to determine the nature of each partition.
926 * Root? Swap? Architecture? etc.
928 let all_partitions : (partition * nature) list =
929 (* Output of 'file' command for Linux swap file. *)
930 let swap = Pcre.regexp "Linux.*swap.*file" in
931 (* Contents of /etc/redhat-release. *)
932 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
933 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
934 (* Contents of /etc/debian_version. *)
935 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
936 (* Output of 'file' on certain executables. *)
937 let i386 = Pcre.regexp ", Intel 80386," in
938 let x86_64 = Pcre.regexp ", x86-64," in
939 let itanic = Pcre.regexp ", IA-64," in
941 (* Examine the filesystem mounted on 'mnt' to determine the
942 * operating system, and, if Linux, the distro.
945 if is_dir (mnt ^ "/Windows") = Some true &&
946 is_file (mnt ^ "/autoexec.bat") = Some true then
948 else if is_dir (mnt ^ "/etc") = Some true &&
949 is_dir (mnt ^ "/sbin") = Some true &&
950 is_dir (mnt ^ "/var") = Some true then (
951 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
952 let chan = open_in (mnt ^ "/etc/redhat-release") in
953 let lines = input_all_lines chan in
957 | [] -> (* empty /etc/redhat-release ...? *)
958 LinuxRoot (UnknownArch, OtherLinux)
959 | line::_ -> (* try to detect OS from /etc/redhat-release *)
961 let subs = Pcre.exec ~rex:rhel line in
962 let major = int_of_string (Pcre.get_substring subs 1) in
964 try int_of_string (Pcre.get_substring subs 2)
965 with Not_found -> 0 in
966 LinuxRoot (UnknownArch, RHEL (major, minor))
968 Not_found | Failure "int_of_string" ->
970 let subs = Pcre.exec ~rex:fedora line in
971 let version = int_of_string (Pcre.get_substring subs 1) in
972 LinuxRoot (UnknownArch, Fedora version)
974 Not_found | Failure "int_of_string" ->
975 LinuxRoot (UnknownArch, OtherLinux)
977 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
978 let chan = open_in (mnt ^ "/etc/debian_version") in
979 let lines = input_all_lines chan in
983 | [] -> (* empty /etc/debian_version ...? *)
984 LinuxRoot (UnknownArch, OtherLinux)
985 | line::_ -> (* try to detect version from /etc/debian_version *)
987 let subs = Pcre.exec ~rex:debian line in
988 let major = int_of_string (Pcre.get_substring subs 1) in
989 let minor = int_of_string (Pcre.get_substring subs 2) in
990 LinuxRoot (UnknownArch, Debian (major, minor))
992 Not_found | Failure "int_of_string" ->
993 LinuxRoot (UnknownArch, OtherLinux)
996 LinuxRoot (UnknownArch, OtherLinux)
997 ) else if is_dir (mnt ^ "/grub") = Some true &&
998 is_file (mnt ^ "/grub/stage1") = Some true then (
1001 NotRoot (* mountable, but not a root filesystem *)
1004 (* Examine the Linux root filesystem mounted on 'mnt' to
1005 * determine the architecture. We do this by looking at some
1006 * well-known binaries that we expect to be there.
1008 let detect_architecture mnt =
1009 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
1010 match shget cmd with
1011 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
1012 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
1013 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
1019 let dev = dev_of_partition part in (* Get /dev device. *)
1022 (* Use 'file' command to detect if it is swap. *)
1023 let cmd = "file -sbL " ^ quote dev in
1024 match shget cmd with
1025 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
1027 (* Blindly try to mount the device. *)
1028 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
1029 match shwithstatus cmd with
1031 let os = detect_os "/mnt/root" in
1034 | LinuxRoot (UnknownArch, distro) ->
1035 let architecture = detect_architecture "/mnt/root" in
1036 LinuxRoot (architecture, distro)
1038 sh "umount /mnt/root";
1041 | _ -> UnknownNature (* not mountable *)
1045 eprintf "partition detection: %s is %s\n%!"
1046 dev (string_of_nature nature);
1052 print_endline (s_ "Finished detecting hard drives.");
1054 (* Autodetect system memory. *)
1056 (* Try to parse dmesg first to find the 'Memory:' report when
1057 * the kernel booted. If available, this can give us an
1058 * indication of usable RAM on this system.
1060 let dmesg = shget "dmesg" in
1063 match dmesg with Some lines -> lines | None -> raise Not_found in
1065 List.find (fun line -> String.starts_with line "Memory: ") dmesg in
1066 let subs = Pcre.exec ~pat:"k/([[:digit:]]+)k available" line in
1067 let mem = Pcre.get_substring subs 1 in
1068 int_of_string mem / 1024
1070 Not_found | Failure "int_of_string" ->
1071 (* 'dmesg' can't be parsed. The backup plan is to look
1074 let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
1076 | Some (mem::_) -> int_of_float (float_of_string mem)
1078 (* For some reason even /proc/meminfo didn't work. Just
1079 * assume 256 MB instead.
1083 (* Autodetect system # pCPUs. *)
1084 let system_nr_cpus =
1086 shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
1088 | Some (cpus::_) -> int_of_string cpus
1091 (* Greeting, type of transfer, network question stages.
1092 * These are all done in newt mode.
1094 let config_transfer_type, config_network =
1098 if !config_greeting then
1099 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);
1101 (* Type of transfer. *)
1102 let config_transfer_type =
1103 match !config_transfer_type with
1107 s_ "Physical to Virtual (P2V)", P2V;
1108 s_ "Virtual to Virtual (V2V)", V2V;
1111 select_single ~stage:(s_ "Transfer type") 40
1112 (s_ "Transfer type")
1115 (* Network configuration. *)
1116 let config_network =
1117 match !config_network with
1120 open_centered_window ~stage:(s_ "Network")
1121 60 20 (s_ "Configure network");
1123 let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in
1124 Newt.listbox_set_width autolist 52;
1126 (* Populate the "Automatic" listbox with RHEL/Fedora
1127 * root partitions found which allow us to do
1128 * automatic configuration in a known way.
1130 let rec loop = function
1132 | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
1136 (dev_of_partition partition)
1137 (string_of_linux_distro distro) in
1138 ignore (Newt.listbox_append_entry autolist label partition);
1140 | _ :: parts -> loop parts
1142 loop all_partitions;
1144 (* If there is no suitable root partition (the listbox
1145 * is empty) then disable the auto option and the listbox.
1147 let no_auto = Newt.listbox_item_count autolist = 0 in
1150 Newt.radio_button 1 1
1151 (s_ "Automatic from:") (not no_auto) None in
1153 Newt.radio_button 1 6
1154 (s_ "Start a shell") no_auto (Some auto) in
1157 Newt.component_takes_focus auto false;
1158 Newt.component_takes_focus
1159 (Newt.component_of_listbox autolist) false
1163 Newt.radio_button 1 7
1164 (s_ "QEMU user network") false (Some shell) in
1166 Newt.radio_button 1 8
1167 (s_ "Don't configure the network") false (Some qemu) in
1169 Newt.radio_button 1 9
1170 (s_ "Static configuration:") false (Some nonet) in
1172 let label1 = Newt.label 4 10 (s_ "Interface") in
1173 let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
1174 let label2 = Newt.label 4 11 (s_ "IP") in
1175 let entry2 = Newt.entry 16 11 None 16 [] in
1176 let label3 = Newt.label 4 12 (s_ "Netmask") in
1177 let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
1178 let label4 = Newt.label 4 13 (s_ "Gateway") in
1179 let entry4 = Newt.entry 16 13 None 16 [] in
1180 let label5 = Newt.label 4 14 (s_ "Nameserver") in
1181 let entry5 = Newt.entry 16 14 None 16 [] in
1183 let enable_static () =
1184 Newt.component_takes_focus entry1 true;
1185 Newt.component_takes_focus entry2 true;
1186 Newt.component_takes_focus entry3 true;
1187 Newt.component_takes_focus entry4 true;
1188 Newt.component_takes_focus entry5 true
1191 let disable_static () =
1192 Newt.component_takes_focus entry1 false;
1193 Newt.component_takes_focus entry2 false;
1194 Newt.component_takes_focus entry3 false;
1195 Newt.component_takes_focus entry4 false;
1196 Newt.component_takes_focus entry5 false
1199 let enable_autolist () =
1200 Newt.component_takes_focus
1201 (Newt.component_of_listbox autolist) true
1203 let disable_autolist () =
1204 Newt.component_takes_focus
1205 (Newt.component_of_listbox autolist) false
1209 Newt.component_add_callback auto
1210 (fun () ->disable_static (); enable_autolist ());
1211 Newt.component_add_callback shell
1212 (fun () -> disable_static (); disable_autolist ());
1213 Newt.component_add_callback qemu
1214 (fun () -> disable_static (); disable_autolist ());
1215 Newt.component_add_callback nonet
1216 (fun () -> disable_static (); disable_autolist ());
1217 Newt.component_add_callback static
1218 (fun () -> enable_static (); disable_autolist ());
1220 let ok = Newt.button 48 16 ok_button in
1222 let form = Newt.form None None [] in
1223 Newt.form_add_components form [auto;
1224 Newt.component_of_listbox autolist;
1225 shell;qemu;nonet;static;
1226 label1;label2;label3;label4;label5;
1227 entry1;entry2;entry3;entry4;entry5;
1232 ignore (Newt.run_form form);
1234 let r = Newt.radio_get_current auto in
1235 if Newt.component_equals r auto then (
1236 match Newt.listbox_get_current autolist with
1238 | Some part -> Auto part
1240 else if Newt.component_equals r shell then Shell
1241 else if Newt.component_equals r qemu then QEMUUserNet
1242 else if Newt.component_equals r nonet then NoNetwork
1243 else if Newt.component_equals r static then (
1244 let interface = Newt.entry_get_value entry1 in
1245 let address = Newt.entry_get_value entry2 in
1246 let netmask = Newt.entry_get_value entry3 in
1247 let gateway = Newt.entry_get_value entry4 in
1248 let nameserver = Newt.entry_get_value entry5 in
1249 if interface = "" || address = "" ||
1250 netmask = "" || gateway = "" then
1253 Static (interface, address, netmask, gateway, nameserver)
1262 config_transfer_type, config_network
1265 (* Try to bring up the network. *)
1266 (match config_network with
1268 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");
1271 | Static (interface, address, netmask, gateway, nameserver) ->
1272 print_endline (s_ "Trying static network configuration.\n");
1273 if not (static_network
1274 (interface, address, netmask, gateway, nameserver)) then (
1275 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");
1281 (s_ "Trying network auto-configuration from root filesystem ...\n");
1283 (* Mount the root filesystem read-only under /mnt/root. *)
1284 sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");
1286 if not (auto_network ()) then (
1287 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");
1291 (* NB. Lazy unmount is required because dhclient keeps its current
1292 * directory open on /etc/sysconfig/network-scripts/
1294 sh ("umount -l /mnt/root");
1297 print_endline (s_ "Trying QEMU network configuration.\n");
1300 | NoNetwork -> (* this is easy ... *) ()
1303 (* SSH configuration phase. *)
1307 match !config_ssh with
1310 (* Query the user for SSH configuration. *)
1311 open_centered_window ~stage:(s_ "SSH configuration")
1312 60 20 (s_ "SSH configuration");
1314 let label1 = Newt.label 1 1 (s_ "Remote host") in
1315 let host = Newt.entry 20 1 None 36 [] in
1316 let label2 = Newt.label 1 2 (s_ "Remote port") in
1317 let port = Newt.entry 20 2 (Some "22") 6 [] in
1318 let label3 = Newt.label 1 3 (s_ "Remote directory") in
1319 let dir = Newt.entry 20 3 (Some "/var/lib/xen/images") 36 [] in
1320 let label4 = Newt.label 1 4 (s_ "SSH username") in
1321 let user = Newt.entry 20 4 (Some "root") 16 [] in
1323 There's no sensible way to support this for SSH:
1324 let label5 = Newt.label 1 5 (s_ "SSH password") in
1325 let pass = Newt.entry 20 5 None 16 [Newt.PASSWORD] in
1329 Newt.checkbox 16 7 (s_ "Use SSH compression (not good for LANs)")
1333 Newt.checkbox 16 9 (s_ "Test SSH connection") '*' None in
1335 let ok = Newt.button 48 16 ok_button in
1337 let form = Newt.form None None [] in
1338 Newt.form_add_components form [label1;label2;label3;label4;
1345 ignore (Newt.run_form form);
1346 let host = Newt.entry_get_value host in
1347 let port = Newt.entry_get_value port in
1348 let dir = Newt.entry_get_value dir in
1349 let user = Newt.entry_get_value user in
1350 let compr = Newt.checkbox_get_value compr = '*' in
1351 let check = Newt.checkbox_get_value check = '*' in
1352 if host <> "" && port <> "" && user <> "" then
1353 { ssh_host = host; ssh_port = port; ssh_directory = dir;
1354 ssh_username = user;
1355 ssh_compression = compr;
1356 ssh_check = check; }
1366 (* If asked, check the SSH connection. *)
1367 if config_ssh.ssh_check then
1368 if not (test_ssh config_ssh) then
1369 failwith (s_ "SSH configuration failed");
1371 (* Devices and root partition and target configuration selection stage. *)
1372 let config_devices_to_send, config_root_filesystem, config_target =
1375 let config_devices_to_send =
1376 match !config_devices_to_send with
1379 let items = List.map (
1382 sprintf "/dev/%s (%.3f GB)" dev
1383 ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in
1385 ) all_block_devices in
1387 select_multiple ~stage:(s_ "Block devices")
1389 (s_ "Select block devices to send")
1392 let config_root_filesystem =
1393 match !config_root_filesystem with
1396 let items = List.map (
1397 fun (part, nature) ->
1399 sprintf "%s %s" (dev_of_partition part)
1400 (string_of_nature nature) in
1404 select_single ~stage:(s_ "Root filesystem") 60
1405 (s_ "Select root filesystem")
1409 match !config_target with
1412 open_centered_window ~stage:(s_ "Target system") 40 20
1413 (s_ "Configure target system");
1415 let hvlabel = Newt.label 1 1 (s_ "Hypervisor:") in
1416 let hvlistbox = Newt.listbox 16 1 4 [Newt.SCROLL] in
1417 Newt.listbox_append_entry hvlistbox "Xen" (Some Xen);
1418 Newt.listbox_append_entry hvlistbox "QEMU" (Some QEMU);
1419 Newt.listbox_append_entry hvlistbox "KVM" (Some KVM);
1420 Newt.listbox_append_entry hvlistbox "Other" None;
1422 let archlabel = Newt.label 1 5 (s_ "Architecture:") in
1423 let archlistbox = Newt.listbox 16 5 4 [Newt.SCROLL] in
1424 Newt.listbox_append_entry archlistbox "i386" I386;
1425 Newt.listbox_append_entry archlistbox
1426 "x86-64 (64-bit x86)" X86_64;
1427 Newt.listbox_append_entry archlistbox "IA64 (Itanium)" IA64;
1428 Newt.listbox_append_entry archlistbox "PowerPC 32-bit" PPC;
1429 Newt.listbox_append_entry archlistbox "PowerPC 64-bit" PPC64;
1430 Newt.listbox_append_entry archlistbox "SPARC 32-bit" SPARC;
1431 Newt.listbox_append_entry archlistbox "SPARC 64-bit" SPARC64;
1432 Newt.listbox_append_entry archlistbox "Unknown/other" UnknownArch;
1434 (* Get the architecture of the selected root filesystem.
1435 * If not known, default to UnknownArch.
1437 Newt.listbox_set_current_by_key archlistbox UnknownArch;
1439 match List.assoc config_root_filesystem all_partitions with
1440 | LinuxRoot (arch, _) ->
1441 Newt.listbox_set_current_by_key archlistbox arch
1446 let memlabel = Newt.label 1 9 (s_ "Memory (MB):") in
1447 let mementry = Newt.entry 16 9
1448 (Some (string_of_int system_memory)) 8 [] in
1449 let cpulabel = Newt.label 1 10 (s_ "CPUs:") in
1450 let cpuentry = Newt.entry 16 10
1451 (Some (string_of_int system_nr_cpus)) 4 [] in
1452 let maclabel = Newt.label 1 11 (s_ "MAC addr:") in
1453 let macentry = Newt.entry 16 11 None 20 [] in
1455 Newt.label 1 12 (s_ "(leave MAC blank for random)") in
1458 Newt.checkbox 12 14 (s_ "Use remote libvirtd") '*' None in
1460 let ok = Newt.button 28 16 ok_button in
1462 let form = Newt.form None None [] in
1463 Newt.form_add_components form
1464 [hvlabel; Newt.component_of_listbox hvlistbox;
1465 archlabel; Newt.component_of_listbox archlistbox;
1468 maclabel; macentry; maclabel2;
1474 ignore (Newt.run_form form);
1476 let hv = Newt.listbox_get_current hvlistbox in
1477 let arch = Newt.listbox_get_current archlistbox in
1478 let mem = int_of_string (Newt.entry_get_value mementry) in
1479 let cpus = int_of_string (Newt.entry_get_value cpuentry) in
1480 let mac = Newt.entry_get_value macentry in
1481 let libvirtd = Newt.checkbox_get_value libvirtd = '*' in
1482 if hv <> None && arch <> None && mem >= 0 && cpus >= 0
1484 { tgt_hypervisor = Option.get hv;
1485 tgt_architecture = Option.get arch;
1486 tgt_memory = mem; tgt_vcpus = cpus;
1488 if mac <> "" then mac else random_mac_address ();
1489 tgt_libvirtd = libvirtd }
1493 Not_found | Failure "int_of_string" -> loop ()
1501 config_devices_to_send, config_root_filesystem, config_target
1504 (* If architecture is set to UnknownArch, then assume the same
1505 * architecture as the live CD.
1508 match config_target.tgt_architecture with
1510 let arch = shget "uname -m" in
1513 | Some (arch :: _) -> architecture_of_string arch
1514 | _ -> I386 (* probably wrong XXX *) in
1515 { config_target with tgt_architecture = arch }
1516 | _ -> config_target in
1518 (* Try to get the capabilities from the remote machine. If we fail
1519 * it doesn't matter too much.
1521 let caps_os_type, caps_emulator, caps_loader, caps_machine =
1523 if not config_target.tgt_libvirtd then raise Not_found;
1526 match config_target.tgt_hypervisor with
1527 | Some Xen -> "xen", "/"
1528 | Some (QEMU|KVM) -> "qemu", "/system"
1529 | None -> raise Not_found in
1531 sprintf "%s+ssh://%s@%s:%s%s"
1532 proto config_ssh.ssh_username
1533 config_ssh.ssh_host config_ssh.ssh_port path in
1534 eprintf "capabilities URI = %S\n%!" name;
1536 print_endline (s_ "Try to fetch remote hypervisor capabilities ...\n");
1538 let conn = Libvirt.Connect.connect_readonly ~name () in
1539 let caps = Libvirt.Connect.get_capabilities conn in
1540 Libvirt.Connect.close conn;
1542 (* Turn it into XML data. *)
1543 let caps = Xml.parse_string caps in
1544 eprintf "capabilities:\n%s\n%!" (Xml.to_string_fmt caps);
1546 (* We're looking for a guest with <os_type>hvm</os_type>
1547 * and <arch name="target-arch">... Later when we can
1548 * install PV drivers automatically, we will want to look
1549 * for paravirt guest types too.
1551 let guests = children_with_name "guest" caps in
1553 List.filter (xml_has_pcdata_child "os_type" "hvm") guests in
1554 let arch_str = string_of_architecture config_target.tgt_architecture in
1557 xml_has_child_matching (
1559 | Xml.Element (n, attribs, _)
1564 (* deal with i386 vs i686 pestilence *)
1565 architecture_of_string a = config_target.tgt_architecture
1572 (* In theory at this point we only have a single guest type
1573 * remaining. It might be that we have _zero_ available
1574 * guest types, which indicates probably an unsupported
1575 * capability of the remote hypervisor (or just that one of
1576 * many parsing or heuristics failed). It might be that
1577 * we have > 1 available guest types, which indicates some
1578 * feature we don't know about.
1580 let len = List.length guests in
1582 message_box (s_ "Warning")
1583 (sprintf (f_ "Remote hypervisor claims not to support fully virtualized %s guests.\n\nContinuing anyway.\n\n%!") arch_str);
1588 message_box (s_ "Note")
1589 (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)
1592 let guest = List.hd guests in
1595 try Some (find_pcdata_child "os_type" guest)
1596 with Not_found -> None in
1597 let arch_section = find_child_with_name "arch" guest in
1599 try Some (find_pcdata_child "emulator" arch_section)
1600 with Not_found -> None in
1602 try Some (find_pcdata_child "loader" arch_section)
1603 with Not_found -> None in
1605 try Some (find_pcdata_child "machine" arch_section)
1606 with Not_found -> None in
1608 os_type, emulator, loader, machine
1610 | Not_found -> None, None, None, None
1612 eprintf "XML error: %s\n%!" (Xml.error err);
1613 None, None, None, None
1614 | Xml.Not_element _ | Xml.Not_pcdata _ | Xml.No_attribute _ ->
1615 (* If these occur, need to add some more debugging. *)
1616 eprintf "XML error when parsing capabilities\n%!";
1617 None, None, None, None
1618 | Libvirt.Virterror err ->
1619 eprintf "libvirt error: %s\n%!" (Libvirt.Virterror.to_string err);
1620 None, None, None, None
1621 | Invalid_argument str ->
1622 eprintf "libvirt error: %s\n%!" str;
1623 None, None, None, None in
1625 (* In test mode, exit here before we do Bad Things to the developer's
1628 if test_dialog_stages then exit 1;
1630 print_endline (s_ "Performing LVM snapshots ...\n");
1632 (* Switch LVM config. *)
1634 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1635 sh "rm -f /etc/lvm/cache/.cache";
1636 sh "rm -f /etc/lvm.new/cache/.cache";
1638 (* Snapshot the block devices to send. *)
1639 let config_devices_to_send =
1642 let snapshot_dev = snapshot_name origin_dev in
1643 snapshot origin_dev snapshot_dev;
1644 (origin_dev, snapshot_dev)
1645 ) config_devices_to_send in
1647 (* Run kpartx on the snapshots. *)
1649 fun (origin, snapshot) ->
1650 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1651 ) config_devices_to_send;
1653 (* Rescan for LVs. *)
1657 (* Mount the root filesystem under /mnt/root. *)
1658 (match config_root_filesystem with
1659 | Part (dev, partnum) ->
1660 let dev = dev ^ partnum in
1661 let snapshot_dev = snapshot_name dev in
1662 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1665 (* The LV will be backed by a snapshot device, so just mount
1668 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1671 (* Work out what devices will be called at the remote end. *)
1672 let config_devices_to_send = List.map (
1673 fun (origin_dev, snapshot_dev) ->
1674 let remote_dev = remote_of_origin_dev origin_dev in
1675 (origin_dev, snapshot_dev, remote_dev)
1676 ) config_devices_to_send in
1678 (* Modify files on the root filesystem. *)
1679 rewrite_fstab config_devices_to_send;
1680 (* XXX Other files to rewrite? *)
1682 (* Unmount the root filesystem and sync disks. *)
1683 sh "umount /mnt/root";
1684 sh "sync"; (* Ugh, should be in stdlib. *)
1686 (* XXX This is using the hostname derived from network configuration
1687 * above. We might want to ask the user to choose.
1689 let hostname = safe_name (gethostname ()) in
1691 let date = sprintf "%04d%02d%02d%02d%02d"
1692 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1693 "p2v-" ^ hostname ^ "-" ^ date in
1695 (* Work out what the image filenames will be at the remote end. *)
1696 let config_devices_to_send = List.map (
1697 fun (origin_dev, snapshot_dev, remote_dev) ->
1698 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1699 (origin_dev, snapshot_dev, remote_dev, remote_name)
1700 ) config_devices_to_send in
1702 (* Write a configuration file. Not sure if this is any better than
1703 * just 'sprintf-ing' bits of XML text together, but at least we will
1704 * always get well-formed XML.
1706 * XXX There is a case for using virt-install to generate this XML.
1707 * When we start to incorporate libvirt access & storage API this
1708 * needs to be rethought.
1710 let conf_filename = basename ^ ".conf" in
1713 (* Shortcut to make "<name>value</name>". *)
1714 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1715 (* ... and the _other_ sort of leaf (god I hate XML). *)
1716 let tleaf name attribs = Xml.Element (name, attribs, []) in
1719 string_of_architecture config_target.tgt_architecture in
1721 wordsize_of_architecture config_target.tgt_architecture in
1723 (* Standard stuff for every domain. *)
1724 let name = leaf "name" hostname in
1725 let uuid = leaf "uuid" (random_uuid ()) in
1726 let maxmem, memory =
1727 let m = string_of_int (config_target.tgt_memory * 1024) in
1728 leaf "maxmem" m, leaf "memory" m in
1729 let vcpu = leaf "vcpu" (string_of_int config_target.tgt_vcpus) in
1731 (* Top-level stuff which differs for each HV type (isn't this supposed
1732 * to be portable ...)
1735 (* Use capabilities for os_type, etc. else use some good guesses. *)
1736 let os_type = Option.default "hvm" caps_os_type in
1737 let machine = Option.default "pc" caps_machine in
1738 let loader = Option.default "/usr/lib/xen/boot/hvmloader" caps_loader in
1740 match config_target.tgt_hypervisor with
1742 [Xml.Element ("os", [],
1743 [leaf "type" os_type;
1744 leaf "loader" loader;
1745 tleaf "boot" ["dev", "hd"]]);
1746 Xml.Element ("features", [],
1750 tleaf "clock" ["sync", "localtime"]]
1752 [Xml.Element ("os", [], [leaf "type" os_type]);
1753 tleaf "clock" ["sync", "localtime"]]
1755 [Xml.Element ("os", [],
1756 [Xml.Element ("type",
1758 "machine", machine],
1759 [Xml.PCData os_type]);
1760 tleaf "boot" ["dev", "hd"]])]
1764 (* <devices> section. *)
1767 match caps_emulator with
1768 (* Use the emulator from the libvirt capabilities. *)
1769 | Some s -> [leaf "emulator" s]
1771 (* If we don't have libvirt capabilities, best guess. *)
1772 match config_target.tgt_hypervisor with
1775 (if arch_wordsize = W64 then "/usr/lib64/xen/bin/qemu-dm"
1776 else "/usr/lib/xen/bin/qemu-dm")]
1778 [leaf "emulator" "/usr/bin/qemu"]
1780 [leaf "emulator" "/usr/bin/qemu-kvm"]
1784 Xml.Element ("interface", ["type", "user"],
1785 [tleaf "mac" ["address",
1786 config_target.tgt_mac_address]]) in
1787 (* XXX should have an option for Xen bridging:
1789 "interface", ["type","bridge"],
1790 [tleaf "source" ["bridge","xenbr0"];
1791 tleaf "mac" ["address",mac_address];
1792 tleaf "script" ["path","vif-bridge"]])*)
1793 let graphics = tleaf "graphics" ["type", "vnc"] in
1795 let disks = List.map (
1796 fun (_, _, remote_dev, remote_name) ->
1798 "disk", ["type", "file";
1800 [tleaf "source" ["file",
1801 config_ssh.ssh_directory ^ "/" ^ remote_name];
1802 tleaf "target" ["dev", remote_dev]]
1804 ) config_devices_to_send in
1808 emulator @ interface :: graphics :: disks
1811 (* Put it all together in <domain type='foo'>. *)
1814 (match config_target.tgt_hypervisor with
1815 | Some Xen -> ["type", "xen"]
1816 | Some QEMU -> ["type", "qemu"]
1817 | Some KVM -> ["type", "kvm"]
1819 name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
1822 (* Convert XML configuration file to a string, then send it to the
1826 let xml = Xml.to_string_fmt xml in
1829 match config_target.tgt_hypervisor with
1830 | Some Xen | None -> ""
1831 | Some QEMU | Some KVM -> " -c qemu:///system" in
1832 let xml = sprintf (f_ "\
1834 This is an automatically generated libvirt configuration file.
1835 It was written by the %s program.
1837 Please check the values in this configuration file carefully,
1838 particularly maxmem, memory, vcpu and any paths.
1840 To start the domain, do:
1843 -->\n\n") program_name conn_arg conf_filename conn_arg hostname
1847 let xml_len = String.length xml in
1848 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1850 print_endline (s_ "\nWriting configuration file ...\n");
1852 let (sock,_) as conn = ssh_start_upload config_ssh conf_filename in
1853 (* In OCaml this actually loops calling write(2) *)
1854 ignore (write sock xml 0 xml_len);
1855 ssh_finish_upload conn in
1857 (* Send the device snapshots to the remote host. *)
1858 (* XXX This code should be made more robust against both network
1859 * errors and local I/O errors. Also should allow the user several
1860 * attempts to connect, or let them go back to the dialog stage.
1863 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1864 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1867 try List.assoc origin_dev all_block_devices
1868 with Not_found -> assert false (* internal error *) in
1871 printf (f_ "\nSending /dev/%s (%.3f GB) to remote machine\n\n%!")
1872 origin_dev ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in
1874 (* Open the snapshot device. *)
1875 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1878 let (sock,_) as conn = ssh_start_upload config_ssh remote_name in
1880 (* Copy the data. *)
1881 let spinners = "|/-\\" (* "Oo" *) in
1882 let bufsize = 1024 * 1024 in
1883 let buffer = String.create bufsize in
1884 let start = gettimeofday () in
1886 let rec copy bytes_sent last_printed_at spinner =
1887 let n = read fd buffer 0 bufsize in
1889 let n' = write sock buffer 0 n in
1890 if n <> n' then assert false; (* never, according to the manual *)
1892 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1893 let last_printed_at, spinner =
1894 let now = gettimeofday () in
1895 (* Print progress every few seconds. *)
1896 if now -. last_printed_at > 2. then (
1897 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1898 let secs_elapsed = now -. start in
1899 printf "%.0f%% %c %.1f Mbps"
1900 (100. *. elapsed) spinners.[spinner]
1901 (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
1902 (* After 60 seconds has elapsed, start printing estimates. *)
1903 if secs_elapsed >= 60. then (
1904 let remaining = 1. -. elapsed in
1905 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1906 if secs_remaining > 120. then
1907 printf (f_ " (about %.0f minutes remaining)")
1908 (secs_remaining/.60.)
1910 printf (f_ " (about %.0f seconds remaining)")
1914 let spinner = (spinner + 1) mod String.length spinners in
1917 else last_printed_at, spinner in
1919 copy bytes_sent last_printed_at spinner
1923 printf "\n\n%!"; (* because of the messages printed above *)
1926 ssh_finish_upload conn
1927 ) config_devices_to_send;
1929 (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
1931 (* Clean up and reboot. *)
1933 message_box (sprintf (f_ "%s has finished") program_name)
1934 (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.")
1935 config_ssh.ssh_directory conf_filename)
1943 (*----------------------------------------------------------------------*)
1946 let () = eprintf (f_ "usage: virt-p2v [--test] [ttyname]\n%!") in
1949 (* Make sure that exceptions from 'main' get printed out on stdout
1950 * as well as stderr, since stderr is probably redirected to the
1951 * logfile, and so not visible to the user.
1953 let handle_exn f arg =
1956 print_endline (Printexc.to_string exn);
1959 (* Test harness for the Makefile. The Makefile invokes this script as
1960 * 'virt-p2v --test' just to check it compiles. When it is running
1961 * from the actual live CD, there is a single parameter which is the
1962 * tty name (so usually 'virt-p2v tty1').
1965 match Array.to_list Sys.argv with
1966 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1967 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1968 | [ _; ttyname ] -> (* Run main with ttyname. *)
1969 handle_exn main (Some ttyname)
1970 | [ _ ] -> (* Interactive - no ttyname. *)
1971 handle_exn main None
1974 (* This file must end with a newline *)