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 | P2V (* physical to virtual *)
26 | V2V (* virtual to virtual *)
27 (*| V2P*) (* virtual to physical - not impl *)
29 | HD of string (* eg. HD "a" for /dev/hda *)
30 | SD of string (* eg. SD "b" for /dev/sdb *)
31 | CCISS of int * int (* eg. CCISS (0,0) for /dev/cciss/c0d0*)
33 | Part of block_device * string (* eg. (HD "a", "1")
34 or (CCISS (0,0), "p1") *)
35 | LV of string * string (* eg. ("VolGroup00", "LogVol00") *)
37 | Auto of partition (* Automatic network configuration. *)
38 | Shell (* Start a shell. *)
39 | QEMUUserNet (* Assume we're running under qemu. *)
40 | Static of string * string * string * string * string
41 (* interface, address, netmask, gateway, nameserver *)
44 ssh_host : string; (* Remote host for SSH. *)
45 ssh_port : string; (* Remote port. *)
46 ssh_directory : string; (* Remote directory. *)
47 ssh_username : string; (* Remote username. *)
48 ssh_compression : bool; (* If true, use SSH compression. *)
49 ssh_check : bool; (* If true, check SSH is working. *)
56 | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
59 type target_config = {
60 tgt_hypervisor : hypervisor option; (* Remote hypervisor. *)
61 tgt_architecture : architecture; (* Remote architecture. *)
62 tgt_memory : int; (* Memory (megabytes). *)
63 tgt_vcpus : int; (* Number of virtual CPUs. *)
64 tgt_mac_address : string; (* MAC address. *)
65 tgt_libvirtd : bool; (* True if libvirtd on remote. *)
68 (*----------------------------------------------------------------------*)
69 (* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section.
71 * If left as they are, then this will create a generic virt-p2v script
72 * which asks the user for each question. If you set the defaults here
73 * then you will get a custom virt-p2v which is partially or even fully
74 * automated and won't ask the user any questions.
76 * Note that 'None' means 'no default' (ie. ask the user) whereas
77 * 'Some foo' means use 'foo' as the answer.
79 * These are documented in the virt-p2v(1) manual page.
81 * After changing them, run './virt-p2v --test' to check syntax.
84 (* If greeting is true, wait for keypress after boot and during
85 * final verification. Set to 'false' for less interactions.
87 let config_greeting = ref true
89 (* General type of transfer. *)
90 let config_transfer_type = ref None
92 (* Network configuration. *)
93 let config_network = ref None
95 (* SSH configuration. *)
96 let config_ssh = ref None
98 (* What to transfer. *)
99 let config_devices_to_send = ref None
101 (* The root filesystem - parts of this get modified after migration. *)
102 let config_root_filesystem = ref None
104 (* Configuration of the target. *)
105 let config_target = ref None
107 (* The name of the program as displayed in various places. *)
108 let program_name = "virt-p2v"
110 (* If you want to test the dialog stages, set this to true. *)
111 let test_dialog_stages = false
113 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
114 (*----------------------------------------------------------------------*)
116 (* Load external libraries. *)
122 #require "xml-light";;
123 #require "gettext-stub";;
131 (*----------------------------------------------------------------------*)
134 * Use s_ "string" to mark a translatable string, and f_ "string %s"
135 * to mark a format string (eg. for printf). There are other
136 * functions: see ocaml-gettext manual and GNU gettext info.
138 * Try not to mark strings which always go to the log file (eg.
142 module P2VGettext = Gettext.Program (
144 let textdomain = "virt-p2v"
147 let dependencies = []
149 ) (GettextStub.Native)
152 let supported_langs =
153 (* Note these strings are NOT translated! *)
154 let nonasian_langs = [
155 "English", "en_US.UTF-8";
158 "\xE6\x97\xA5\xE6\x9C\xAC\xE8\xAA\x9E (Japanese)", "ja_JP.UTF-8"
160 (* Linux console doesn't support Asian or RTL languages. *)
161 let term = try getenv "TERM" with Not_found -> "" in
163 | "linux" -> nonasian_langs
164 | _ -> nonasian_langs @ asian_langs
166 (*----------------------------------------------------------------------*)
167 (* General helper functions. *)
169 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
170 let xs = List.sort ~cmp xs in
171 let rec loop = function
172 | [] -> [] | [x] -> [x]
173 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
174 | x :: xs -> x :: loop xs
178 let input_all_lines chan =
179 let lines = ref [] in
181 while true do lines := input_line chan :: !lines done; []
183 End_of_file -> List.rev !lines
185 (* eg. HD "a" => "hda", or CCISS (0,1) => "cciss/c0d1" *)
186 let short_dev_of_block_device = function
187 | HD n -> sprintf "hd%s" n
188 | SD n -> sprintf "sd%s" n
189 | CCISS (c, d) -> sprintf "cciss/c%dd%d" c d
191 (* Returns the full /dev/ path to a block device. *)
192 let dev_of_block_device dev = "/dev/" ^ short_dev_of_block_device dev
194 (* Returns path to partition or LV without /dev/,
195 * eg. "hda1" or "VolGroup/LogVol"
197 let short_dev_of_partition = function
198 | Part (dev, partnum) -> short_dev_of_block_device dev ^ partnum
199 | LV (vg, lv) -> sprintf "%s/%s" vg lv
201 (* Returns the full /dev/ path to a partition or LV. *)
202 let dev_of_partition part = "/dev/" ^ short_dev_of_partition part
204 (* A PV is loosely defined here as either a device or a partition -
205 * basically anything that could be a PV.
207 type pv = PVDev of block_device | PVPart of partition
209 let string_of_pv = function
210 | PVDev dev -> dev_of_block_device dev
211 | PVPart p -> dev_of_partition p
213 (* Take a device name optionally beginning with /dev/ and work
214 * out if it looks like either a device or partition that we
215 * know how to deal with. If not, returns None.
217 * For the sake of simplifying some code later on, the device
218 * name may also be followed by "(\d+)" which is just ignored.
221 let hdp = Pcre.regexp "^/dev/hd([a-z]+)(\\d+)(\\(\\d+\\))?$" in
222 let hd = Pcre.regexp "^/dev/hd([a-z]+)(\\(\\d\\))?$" in
223 let sdp = Pcre.regexp "^/dev/sd([a-z]+)(\\d+)(\\(\\d+\\))?$" in
224 let sd = Pcre.regexp "^/dev/sd([a-z]+)(\\(\\d+\\))?$" in
225 let ccissp = Pcre.regexp "^/dev/cciss/c(\\d+)d(\\d+)(p\\d+)(\\(\\d+\\))?$" in
226 let cciss = Pcre.regexp "^/dev/cciss/c(\\d+)d(\\d+)(\\(\\d+\\))?$" in
227 let lv = Pcre.regexp "^/dev/(\\w+)/(\\w+)$" in
231 let subs = Pcre.exec ~rex:hdp name in
232 Some (PVPart (Part (HD (Pcre.get_substring subs 1),
233 Pcre.get_substring subs 2)))
236 let subs = Pcre.exec ~rex:hd name in
237 Some (PVDev (HD (Pcre.get_substring subs 1)))
240 let subs = Pcre.exec ~rex:sdp name in
241 Some (PVPart (Part (SD (Pcre.get_substring subs 1),
242 Pcre.get_substring subs 2)))
245 let subs = Pcre.exec ~rex:sd name in
246 Some (PVDev (SD (Pcre.get_substring subs 1)))
249 let subs = Pcre.exec ~rex:ccissp name in
250 let c = int_of_string (Pcre.get_substring subs 1) in
251 let d = int_of_string (Pcre.get_substring subs 2) in
252 Some (PVPart (Part (CCISS (c, d), Pcre.get_substring subs 3)))
255 let subs = Pcre.exec ~rex:cciss name in
256 let c = int_of_string (Pcre.get_substring subs 1) in
257 let d = int_of_string (Pcre.get_substring subs 2) in
258 Some (PVDev (CCISS (c, d)))
261 let subs = Pcre.exec ~rex:lv name in
262 let vg = Pcre.get_substring subs 1 in
263 let lv = Pcre.get_substring subs 2 in
264 Some (PVPart (LV (vg, lv)))
268 let string_of_architecture = function
275 | SPARC64 -> "sparc64"
276 | OtherArch arch -> arch
279 let architecture_of_string = function
281 String.length str = 4 &&
282 (str.[0] = 'i' || str.[0] = 'I') &&
283 (str.[1] >= '3' && str.[1] <= '6') &&
284 str.[2] = '8' && str.[3] = '6' -> I386
285 | "x86_64" | "X86_64" | "x86-64" | "X86-64" -> X86_64
286 | "ia64" | "IA64" -> IA64
287 | "ppc" | "PPC" | "ppc32" | "PPC32" -> PPC
288 | "ppc64" | "PPC64" -> PPC64
289 | "sparc" | "SPARC" | "sparc32" | "SPARC32" -> SPARC
290 | "sparc64" | "SPARC64" -> SPARC64
292 | str -> OtherArch str
295 | W32 | W64 | WUnknown
297 let wordsize_of_architecture = function
305 | OtherArch arch -> WUnknown
306 | UnknownArch -> WUnknown
308 type nature = LinuxSwap
309 | LinuxRoot of architecture * linux_distro
310 | WindowsRoot (* Windows C: *)
311 | LinuxBoot (* Linux /boot *)
312 | NotRoot (* mountable, but not / or /boot *)
314 and linux_distro = RHEL of int * int
316 | Debian of int * int
319 let rec string_of_nature = function
320 | LinuxSwap -> s_ "Linux swap"
321 | LinuxRoot (architecture, distro) ->
322 string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
323 | WindowsRoot -> s_ "Windows root"
324 | LinuxBoot -> s_ "Linux /boot"
325 | NotRoot -> s_ "Mountable non-root"
326 | UnknownNature -> s_ "Unknown partition type"
327 and string_of_linux_distro = function
328 | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
329 | Fedora v -> sprintf "Fedora %d" v
330 | Debian (a,b) -> sprintf "Debian %d.%d" a b
331 | OtherLinux -> "Linux"
333 (* XML helper functions. *)
334 let rec children_with_name name xml =
335 let children = Xml.children xml in
338 | Xml.Element (n, _, _) when n = name -> true
341 and xml_has_pcdata_child name pcdata xml =
342 xml_has_child_matching (
344 | Xml.Element (n, _, [Xml.PCData pcd])
345 when n = name && pcd = pcdata -> true
348 and xml_has_attrib_child name attrib xml =
349 xml_has_child_matching (
351 | Xml.Element (n, attribs, _)
352 when n = name && List.mem attrib attribs -> true
355 and xml_has_child_matching f xml =
356 let children = Xml.children xml in
357 List.exists f children
358 and find_child_with_name name xml =
359 let children = children_with_name name xml in
361 | [] -> raise Not_found
363 and find_pcdata_child name xml =
364 let children = children_with_name name xml in
365 let rec loop = function
366 | [] -> raise Not_found
367 | Xml.Element (_, _, [Xml.PCData pcd]) :: _ -> pcd
372 type ('a, 'b) either = Either of 'a | Or of 'b
374 (* We go into and out of newt mode at various stages, but we might
375 * also need to put up a message at any time. This keeps track of
376 * whether we are in newt mode or not.
378 * General tip: Try to do any complex operations like setting up the
379 * network or probing disks outside newt mode, and try not to throw
380 * exceptions in newt mode.
382 let in_newt = ref false
384 if !in_newt then f ()
388 try Either (Newt.init_and_finish f)
389 with exn -> Or exn in
391 match r with Either r -> r | Or exn -> raise exn
394 (* Clear the screen, open a new centered window, make sure the background
395 * and help messages are consistent.
397 let open_centered_window ?stage width height title =
398 if not !in_newt then failwith (s_ "open_centered_window: not in newt mode");
400 Newt.centered_window width height title;
402 program_name ^ (match stage with
404 | Some stage -> " - " ^ stage) in
405 Newt.draw_root_text 0 0 root_text;
407 (s_ "F12 for next screen | [ALT] [F2] root / no password for shell")
409 let ok_button = " OK "
411 (* Some general dialog boxes. *)
412 let message_box title text =
415 open_centered_window 40 20 title;
417 let textbox = Newt.textbox 1 1 36 14 [Newt.WRAP; Newt.SCROLL] in
418 Newt.textbox_set_text textbox text;
419 let ok = Newt.button 28 16 ok_button in
420 let form = Newt.form None None [] in
421 Newt.form_add_components form [textbox; ok];
423 Newt.component_takes_focus ok true;
425 ignore (Newt.run_form form);
429 (* Fail and exit with error. *)
434 ^ 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
435 message_box (s_ "Error") text;
438 (* Display a dialog with checkboxes, return the multiple selected items. *)
439 let select_multiple ?stage ?(force_one = false) width title items =
442 open_centered_window ?stage width 20 title;
446 fun i (label, handle, selected) ->
448 Newt.checkbox 1 (i+1) label
449 (if selected then '*' else ' ') None in
453 let ok = Newt.button 48 16 ok_button in
456 if List.length entries > 10 then
457 Some (Newt.vertical_scrollbar 58 1 10
458 Newt_int.NEWT_COLORSET_WINDOW
459 Newt_int.NEWT_COLORSET_ACTCHECKBOX)
462 let form = Newt.form vb None [] in
463 Newt.form_add_components form (List.map snd entries);
464 Newt.form_add_component form ok;
468 ignore (Newt.run_form form);
469 let selected = List.filter_map (
471 if Newt.checkbox_get_value cb = '*' then Some handle else None
473 if force_one && selected = [] then loop ()
483 (* Display a dialog with radio buttons, return the single selected item. *)
484 let select_single ?stage width title items =
485 if items = [] then failwith "select_single: no items";
489 open_centered_window ?stage width 20 title;
491 let prev = ref None in
494 fun i (label, handle) ->
495 let rb = Newt.radio_button 1 (i+1) label (!prev = None) !prev in
500 let ok = Newt.button (width-12) 16 ok_button in
503 if List.length entries > 10 then
504 Some (Newt.vertical_scrollbar 58 1 10
505 Newt_int.NEWT_COLORSET_WINDOW
506 Newt_int.NEWT_COLORSET_ACTCHECKBOX)
509 let form = Newt.form vb None [] in
510 Newt.form_add_components form (List.map snd entries);
511 Newt.form_add_component form ok;
515 ignore (Newt.run_form form);
516 let r = Option.get !prev in
517 let r = Newt.radio_get_current r in
518 (* Now we compare 'r' to all the 'rb's in the list
519 * to see which one is selected.
522 List.find (fun (_, rb) -> Newt.component_equals r rb) entries
533 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
534 let quote = Filename.quote
536 (* Run a shell command and check it returns 0. *)
538 eprintf "sh: %s\n%!" cmd;
539 if Sys.command cmd <> 0 then
540 failwith (sprintf (f_ "Command failed:\n\n%s") cmd)
543 eprintf "shfailok: %s\n%!" cmd;
544 ignore (Sys.command cmd)
546 let shwithstatus cmd =
547 eprintf "shwithstatus: %s\n%!" cmd;
550 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
552 eprintf "shget: %s\n%!" cmd;
553 let chan = open_process_in cmd in
554 let lines = input_all_lines chan in
555 match close_process_in chan with
556 | WEXITED 0 -> Some lines (* command succeeded *)
557 | WEXITED _ -> None (* command failed *)
559 failwith (sprintf (f_ "shget: command killed by signal %d") i)
561 failwith (sprintf (f_ "shget: command stopped by signal %d") i)
563 (* Start an interactive shell. Need to juggle file descriptors a bit
564 * because bash write PS1 to stderr (currently directed to the logfile).
568 | 0 -> (* child, runs bash *)
571 (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
573 Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
575 | _ -> (* parent, waits *)
576 eprintf "waiting for subshell to exit\n%!";
579 (* Some true if is dir/file, Some false if not, None if not found. *)
581 try Some ((stat path).st_kind = S_DIR)
582 with Unix_error (ENOENT, "stat", _) -> None
584 try Some ((stat path).st_kind = S_REG)
585 with Unix_error (ENOENT, "stat", _) -> None
587 (*----------------------------------------------------------------------*)
588 (* P2V-specific helper functions. *)
590 (* Generate a predictable safe name containing only letters, numbers
591 * and underscores. If passed a string with no letters or numbers,
592 * generates "_1", "_2", etc.
597 fun () -> incr i; "_" ^ string_of_int !i
600 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
601 let name = String.copy name in
602 let have_safe = ref false in
603 for i = 0 to String.length name - 1 do
604 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
606 if !have_safe then name else next_anon ()
608 (* Parse the output of 'lvs' to get list of LV names, sizes,
609 * corresponding PVs, etc.
611 * Returns a list of LVs, and a list of PVs.
615 shget "lvs --noheadings -o vg_name,lv_name,devices"
619 let all_pvs = ref [] in
620 let lines = List.map Pcre.split lines in
624 | [vg; lv; pvs] | [_; vg; lv; pvs] ->
625 let pvs = String.nsplit pvs "," in
626 let pvs = List.filter_map pv_of_dev pvs in
627 all_pvs := !all_pvs @ pvs;
630 failwith ("lvs: " ^ s_ "unexpected output: " ^
631 String.concat "," line)
633 lvs, sort_uniq !all_pvs
635 (* Get all block devices attached to the system. Also queries and
636 * returns the size in bytes of each. It tries to ignore any
637 * removable block devices like CD-ROMs.
639 let get_all_block_devices () =
640 let sys_block_entries =
641 List.sort (Array.to_list (Sys.readdir "/sys/block")) in
643 let get name filter =
644 let devices = List.filter_map filter sys_block_entries in
645 eprintf "get_all_block_devices: %s: block devices: %s\n%!"
646 name (String.concat "; " (List.map dev_of_block_device devices));
648 (* Run blockdev --getsize64 on each, and reject any where this
649 * fails (probably removable devices).
651 let devices = List.filter_map (
653 let cmd = "blockdev --getsize64 " ^ (dev_of_block_device d) in
654 let lines = shget cmd in
656 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
657 | Some [] | None -> None
659 eprintf "all_block_devices: %s: non-removable block devices: %s\n%!"
662 (List.map (fun (d, b) ->
663 sprintf "%s [%Ld]" (dev_of_block_device d) b)
669 (* Search for hdX. *)
670 let rex = Pcre.regexp "^hd([a-z]+)$" in
673 let subs = Pcre.exec ~rex name in
674 Some (HD (Pcre.get_substring subs 1))
678 let devices = get "hd" filter in
680 (* Search for sdX. *)
681 let rex = Pcre.regexp "^sd([a-z]+)$" in
684 let subs = Pcre.exec ~rex name in
685 Some (SD (Pcre.get_substring subs 1))
689 let devices = devices @ get "sd" filter in
691 (* Search for cciss. *)
692 let rex = Pcre.regexp "^cciss!c(\\d+)d(\\d+)$" in
695 let subs = Pcre.exec ~rex name in
696 let c = int_of_string (Pcre.get_substring subs 1) in
697 let d = int_of_string (Pcre.get_substring subs 2) in
702 let devices = devices @ get "cciss" filter in
705 (* Get the partitions on a block device.
706 * eg. SD "a" -> [Part (SD "a","1"); Part (SD "a", "2")]
708 let get_partitions dev =
709 (* Read the device directory, eg. /sys/block/hda, which we expect
710 * to contain partition devices like /sys/block/hda/hda1 etc.
714 | HD n -> "hd" ^ n, sprintf "^hd%s(.+)$" n
715 | SD n -> "sd" ^ n, sprintf "^sd%s(.+)$" n
717 sprintf "cciss!c%dd%d" c d, sprintf "^cciss!c%dd%d(p.+)$" c d in
718 let rex = Pcre.regexp rex in
719 let dir = "/sys/block/" ^ subdir in
720 let parts = Sys.readdir dir in
721 let parts = Array.to_list parts in
722 let parts = List.filter (
723 fun name -> is_dir (dir ^ "/" ^ name) = Some true
725 let parts = List.filter_map (
728 let subs = Pcre.exec ~rex part in
729 Some (Part (dev, Pcre.get_substring subs 1))
735 (* Generate snapshot device name from device name. *)
736 let snapshot_name dev =
737 "snap" ^ (safe_name (short_dev_of_block_device dev))
739 (* Perform a device-mapper snapshot with ramdisk overlay. *)
741 let next_free_ram_disk =
743 fun () -> incr i; "/dev/ram" ^ string_of_int !i
745 fun origin_dev snapshot_dev ->
746 let ramdisk = next_free_ram_disk () in
747 let origin_dev = dev_of_block_device origin_dev in
749 let cmd = "blockdev --getsz " ^ (quote origin_dev) in
750 let lines = shget cmd in
752 | Some (sectors::_) -> Int64.of_string sectors
754 failwith (sprintf (f_ "Disk snapshot failed: unable to read the size in sectors of block device %s") origin_dev) in
756 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
757 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin %s'"
758 snapshot_dev sectors origin_dev);
759 (* Create the snapshot. *)
760 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
761 snapshot_dev sectors snapshot_dev ramdisk)
763 (* Try to perform automatic network configuration, assuming a Fedora or
764 * RHEL-like root filesystem mounted on /mnt/root.
766 let auto_network () =
767 (* Fedora gives an error if this file doesn't exist. *)
768 sh "touch /etc/resolv.conf";
770 (* NB. Lazy unmount is required because dhclient keeps its current
771 * directory open on /etc/sysconfig/network-scripts/
772 * (Fixed in dhcp >= 4.0.0 but be generous anyway).
774 sh "mount -o bind /mnt/root/etc /etc";
775 let status = shwithstatus "/etc/init.d/network start" in
778 (* Try to ping the default gateway to see if this worked. *)
779 shfailok "ping -c3 `/sbin/ip route list match 0.0.0.0 | head -1 | awk '{print $3}'`";
781 if !config_greeting then (
782 print_endline (s_ "\n\nDid automatic network configuration work?\nHint: If not sure, there is a shell on console [ALT] [F2]");
784 let line = read_line () in
785 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
788 (* Non-interactive: return the status of /etc/init.d/network start. *)
791 (* Configure the network statically. *)
792 let static_network (interface, address, netmask, gateway, nameserver) =
793 let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
795 do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
796 (quote interface) (quote address) (quote netmask));
797 do_cmd_or_exit (sprintf "route add default gw %s %s"
798 (quote gateway) (quote interface));
799 if nameserver <> "" then
800 do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
804 Exit -> false (* failed *)
806 (* http://fabrice.bellard.free.fr/qemu/qemu-doc.html#SEC30 *)
807 let qemu_network () =
808 sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0";
809 sh "route add default gw 10.0.2.2 eth0";
810 sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"
812 (* Make an SSH connection to the remote machine, execute command.
813 * The connection remains open until you call ssh_disconnect, it
814 * times out or there is some error.
816 * NB. The command is NOT quoted.
818 * Returns a pair (file descriptor, channel), both referring to the
819 * same thing. Use whichever is more convenient.
821 let ssh_connect config cmd =
822 let cmd = sprintf "ssh%s -l %s -p %s %s %s"
823 (if config.ssh_compression then " -C" else "")
824 (quote config.ssh_username) (quote config.ssh_port) (quote config.ssh_host)
826 eprintf "ssh_connect: %s\n%!" cmd;
827 let chan = open_process_out cmd in
828 descr_of_out_channel chan, chan
830 let ssh_disconnect (_, chan) =
831 eprintf "ssh_disconnect\n%!";
832 match close_process_out chan with
833 | WEXITED 0 -> () (* OK *)
834 | WEXITED i -> failwith (sprintf (f_ "ssh: exited with error code %d") i)
835 | WSIGNALED i -> failwith (sprintf (f_ "ssh: killed by signal %d") i)
836 | WSTOPPED i -> failwith (sprintf (f_ "ssh: stopped by signal %d") i)
838 (* Use these functions to upload a file. *)
839 let ssh_start_upload config filename =
841 sprintf "cat \\> %s/%s" (quote config.ssh_directory) (quote filename) in
842 ssh_connect config cmd
844 let ssh_finish_upload = ssh_disconnect
846 (* Test SSH connection. *)
847 let test_ssh config =
849 (s_ "Testing SSH connection by listing files in remote directory ...\n");
851 let cmd = sprintf "/bin/ls %s" (quote config.ssh_directory) in
852 let conn = ssh_connect config cmd in
855 if !config_greeting then (
856 print_endline (s_ "\n\nDid SSH work?\nHint: If not sure, there is a shell on console [ALT] [F2]\n");
858 let line = read_line () in
859 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
864 (* Rewrite /mnt/root/etc/fstab. *)
865 let rewrite_fstab remote_map =
866 let filename = "/mnt/root/etc/fstab" in
867 if is_file filename = Some true then (
868 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
870 let chan = open_in filename in
871 let lines = input_all_lines chan in
873 let lines = List.map Pcre.split lines in
874 let lines = List.map (
876 | dev :: rest when String.starts_with dev "/dev/" ->
878 match pv_of_dev dev with (* eg. /dev/sda1 where sda is in the map *)
879 | Some (PVPart (Part (pdev, partnum))) ->
880 (try List.assoc pdev remote_map ^ partnum
881 with Not_found -> dev
883 | Some (PVDev pdev) -> (* eg. /dev/sda *)
884 (try List.assoc pdev remote_map
885 with Not_found -> dev
892 let chan = open_out filename in
895 | [dev; mountpoint; fstype; options; freq; passno] ->
896 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
897 dev mountpoint fstype options freq passno
899 output_string chan (String.concat " " line);
900 output_char chan '\n'
905 (* Generate a random MAC address in the Xen-reserved space. *)
906 let random_mac_address () =
908 List.map (sprintf "%02x") (
909 List.map (fun _ -> Random.int 256) [0;0;0]
911 String.concat ":" ("00"::"16"::"3e"::random)
913 (* Generate a random UUID. *)
915 let hex = "0123456789abcdef" in
917 let str = String.create 32 in
918 for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
921 (*----------------------------------------------------------------------*)
922 (* Main entry point. *)
924 (* The general plan for the main function is to operate in stages:
929 * Information gathering about the system
930 * | (eg. block devices, number of CPUs, etc.)
932 * Greeting and type of transfer question
936 * | (after this point we have a working network)
939 * | (after this point we have a working SSH connection)
941 * Questions about what to transfer (block devs, root fs) <--.
944 * Questions about hypervisor configuration |
947 * Verify information -------- user wants to change info ----/
952 * Prior versions of virt-p2v (the ones which used 'dialog') had support
953 * for a back button so they could go back through dialogs. I removed
954 * this because it was hard to support and not particularly useful.
957 let rec main ttyname =
960 (* Running from an init script. We don't have much of a
961 * login environment, so set one up.
965 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
966 "/usr/bin"; "/bin"]);
967 putenv "HOME" "/root";
968 putenv "LOGNAME" "root";
970 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
973 (* Set up logging to /tmp/virt-p2v.log. *)
974 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
978 (* Log the start up time. *)
979 eprintf "\n\n**************************************************\n\n";
980 let tm = localtime (time ()) in
981 eprintf "%s starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
983 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
985 (* Connect stdin/stdout to the tty. *)
989 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
995 (* Choose language early, so messages are translated. *)
996 if !config_greeting && List.length supported_langs > 1 then (
999 let lang = select_single ~stage:(s_ "Select language") 40
1000 (s_ "Select language")
1004 ignore (GettextStubCompat.setlocale GettextStubCompat.LC_ALL lang)
1008 let () = printf (f_ "%s starting up ...\n%!") program_name in
1010 (* Disable screen blanking on tty. *)
1011 sh "setterm -blank 0";
1013 (* Check that the environment is a sane-looking live CD. If not, bail. *)
1014 if not test_dialog_stages && is_dir "/mnt/root" <> Some true then
1016 (s_ "You should only run this script from the live CD or a USB key.");
1018 (* Start of the information gathering phase. *)
1020 (s_ "Detecting hard drives (this may take some time) ...");
1022 (* Search for all non-removable block devices. Do this early and bail
1023 * if we can't find anything.
1025 * This is a list of block_device, like HD "a", and size in bytes.
1027 let all_block_devices : (block_device * int64) list =
1028 let devices = get_all_block_devices () in
1029 if devices = [] then
1031 (s_ "No non-removable block devices (hard disks, etc.) could be found on this machine.");
1034 (* Search for partitions and LVs (anything that could contain a
1035 * filesystem directly). We refer to these generically as
1038 let all_partitions : partition list =
1040 let lvs, pvs = get_lvs () in
1041 eprintf "all_partitions: PVs: %s\n%!"
1042 (String.concat "; " (List.map string_of_pv pvs));
1043 eprintf "all_partitions: LVs: %s\n%!"
1044 (String.concat "; " (List.map dev_of_partition lvs));
1046 (* For now just ignore any block devices which are PVs. *)
1049 fun (dev, _) -> not (List.mem (PVDev dev) pvs)
1050 ) all_block_devices in
1052 (* Partitions (eg. "sda1", "sda2"). *)
1054 let parts = List.map fst block_devices in
1055 let parts = List.map get_partitions parts in
1056 let parts = List.concat parts in
1057 eprintf "all_partitions: all partitions: %s\n%!"
1058 (String.concat "; " (List.map dev_of_partition parts));
1060 (* Remove any partitions which are PVs. *)
1061 let parts = List.filter (
1063 | (Part _) as p -> not (List.mem (PVPart p) pvs)
1064 | LV _ -> assert false
1067 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
1068 (String.concat "; " (List.map dev_of_partition parts));
1070 (* Concatenate LVs & Parts *)
1073 (* Run blockdev --getsize64 on each partition to get its size.
1075 * Returns a list of partitions and their size in bytes.
1077 let all_partitions : (partition * int64) list =
1080 let cmd = "blockdev --getsize64 " ^ quote (dev_of_partition part) in
1081 let lines = shget cmd in
1083 | Some (blksize::_) -> Some (part, Int64.of_string blksize)
1084 | Some [] | None -> None
1087 (* Try to determine the nature of each partition.
1088 * Root? Swap? Architecture? etc.
1090 let all_partitions : (partition * (int64 * nature)) list =
1091 (* Output of 'file' command for Linux swap file. *)
1092 let swap = Pcre.regexp "Linux.*swap.*file" in
1093 (* Contents of /etc/redhat-release. *)
1094 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
1095 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
1096 (* Contents of /etc/debian_version. *)
1097 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
1098 (* Output of 'file' on certain executables. *)
1099 let i386 = Pcre.regexp ", Intel 80386," in
1100 let x86_64 = Pcre.regexp ", x86-64," in
1101 let itanic = Pcre.regexp ", IA-64," in
1103 (* Examine the filesystem mounted on 'mnt' to determine the
1104 * operating system, and, if Linux, the distro.
1107 if is_dir (mnt ^ "/Windows") = Some true &&
1108 is_file (mnt ^ "/autoexec.bat") = Some true then
1110 else if is_dir (mnt ^ "/etc") = Some true &&
1111 is_dir (mnt ^ "/sbin") = Some true &&
1112 is_dir (mnt ^ "/var") = Some true then (
1113 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
1114 let chan = open_in (mnt ^ "/etc/redhat-release") in
1115 let lines = input_all_lines chan in
1119 | [] -> (* empty /etc/redhat-release ...? *)
1120 LinuxRoot (UnknownArch, OtherLinux)
1121 | line::_ -> (* try to detect OS from /etc/redhat-release *)
1123 let subs = Pcre.exec ~rex:rhel line in
1124 let major = int_of_string (Pcre.get_substring subs 1) in
1126 try int_of_string (Pcre.get_substring subs 2)
1127 with Not_found -> 0 in
1128 LinuxRoot (UnknownArch, RHEL (major, minor))
1130 Not_found | Failure "int_of_string" ->
1132 let subs = Pcre.exec ~rex:fedora line in
1133 let version = int_of_string (Pcre.get_substring subs 1) in
1134 LinuxRoot (UnknownArch, Fedora version)
1136 Not_found | Failure "int_of_string" ->
1137 LinuxRoot (UnknownArch, OtherLinux)
1139 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
1140 let chan = open_in (mnt ^ "/etc/debian_version") in
1141 let lines = input_all_lines chan in
1145 | [] -> (* empty /etc/debian_version ...? *)
1146 LinuxRoot (UnknownArch, OtherLinux)
1147 | line::_ -> (* try to detect version from /etc/debian_version *)
1149 let subs = Pcre.exec ~rex:debian line in
1150 let major = int_of_string (Pcre.get_substring subs 1) in
1151 let minor = int_of_string (Pcre.get_substring subs 2) in
1152 LinuxRoot (UnknownArch, Debian (major, minor))
1154 Not_found | Failure "int_of_string" ->
1155 LinuxRoot (UnknownArch, OtherLinux)
1158 LinuxRoot (UnknownArch, OtherLinux)
1159 ) else if is_dir (mnt ^ "/grub") = Some true &&
1160 is_file (mnt ^ "/grub/stage1") = Some true then (
1163 NotRoot (* mountable, but not a root filesystem *)
1166 (* Examine the Linux root filesystem mounted on 'mnt' to
1167 * determine the architecture. We do this by looking at some
1168 * well-known binaries that we expect to be there.
1170 let detect_architecture mnt =
1171 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
1172 match shget cmd with
1173 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
1174 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
1175 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
1181 let dev = dev_of_partition part in (* Get /dev device. *)
1184 (* Use 'file' command to detect if it is swap. *)
1185 let cmd = "file -sbL " ^ quote dev in
1186 match shget cmd with
1187 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
1189 (* Blindly try to mount the device. *)
1190 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
1191 match shwithstatus cmd with
1193 let os = detect_os "/mnt/root" in
1196 | LinuxRoot (UnknownArch, distro) ->
1197 let architecture = detect_architecture "/mnt/root" in
1198 LinuxRoot (architecture, distro)
1200 sh "umount /mnt/root";
1203 | _ -> UnknownNature (* not mountable *)
1207 eprintf "partition detection: %s is %s\n%!"
1208 dev (string_of_nature nature);
1210 (part, (size, nature))
1214 print_endline (s_ "Finished detecting hard drives.");
1216 (* Autodetect system memory. *)
1218 (* Try to parse dmesg first to find the 'Memory:' report when
1219 * the kernel booted. If available, this can give us an
1220 * indication of usable RAM on this system.
1222 let dmesg = shget "dmesg" in
1225 match dmesg with Some lines -> lines | None -> raise Not_found in
1227 List.find (fun line -> String.starts_with line "Memory: ") dmesg in
1228 let subs = Pcre.exec ~pat:"k/([[:digit:]]+)k available" line in
1229 let mem = Pcre.get_substring subs 1 in
1230 int_of_string mem / 1024
1232 Not_found | Failure "int_of_string" ->
1233 (* 'dmesg' can't be parsed. The backup plan is to look
1236 let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
1238 | Some (mem::_) -> int_of_float (float_of_string mem)
1240 (* For some reason even /proc/meminfo didn't work. Just
1241 * assume 256 MB instead.
1245 (* Autodetect system # pCPUs. *)
1246 let system_nr_cpus =
1248 shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
1250 | Some (cpus::_) -> int_of_string cpus
1253 (* Greeting, type of transfer, network question stages.
1254 * These are all done in newt mode.
1256 let config_transfer_type, config_network =
1260 if !config_greeting then
1261 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);
1263 (* Type of transfer. *)
1264 let config_transfer_type =
1265 match !config_transfer_type with
1269 s_ "Physical to Virtual (P2V)", P2V;
1270 s_ "Virtual to Virtual (V2V)", V2V;
1273 select_single ~stage:(s_ "Transfer type") 40
1274 (s_ "Transfer type")
1277 (* Network configuration. *)
1278 let config_network =
1279 match !config_network with
1282 open_centered_window ~stage:(s_ "Network")
1283 60 20 (s_ "Configure network");
1285 let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in
1286 Newt.listbox_set_width autolist 52;
1288 (* Populate the "Automatic" listbox with RHEL/Fedora
1289 * root partitions found which allow us to do
1290 * automatic configuration in a known way.
1292 let rec loop = function
1294 | (partition, (_, LinuxRoot (_, ((RHEL _|Fedora _) as distro))))
1298 (dev_of_partition partition)
1299 (string_of_linux_distro distro) in
1300 ignore (Newt.listbox_append_entry autolist label partition);
1302 | _ :: parts -> loop parts
1304 loop all_partitions;
1306 (* If there is no suitable root partition (the listbox
1307 * is empty) then disable the auto option and the listbox.
1309 let no_auto = Newt.listbox_item_count autolist = 0 in
1312 Newt.radio_button 1 1
1313 (s_ "Automatic from:") (not no_auto) None in
1315 Newt.radio_button 1 6
1316 (s_ "Start a shell") no_auto (Some auto) in
1319 Newt.component_takes_focus auto false;
1320 Newt.component_takes_focus
1321 (Newt.component_of_listbox autolist) false
1325 Newt.radio_button 1 7
1326 (s_ "QEMU user network") false (Some shell) in
1328 Newt.radio_button 1 8
1329 (s_ "Don't configure the network") false (Some qemu) in
1331 Newt.radio_button 1 9
1332 (s_ "Static configuration:") false (Some nonet) in
1334 let label1 = Newt.label 4 10 (s_ "Interface") in
1335 let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
1336 let label2 = Newt.label 4 11 (s_ "IP") in
1337 let entry2 = Newt.entry 16 11 None 16 [] in
1338 let label3 = Newt.label 4 12 (s_ "Netmask") in
1339 let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
1340 let label4 = Newt.label 4 13 (s_ "Gateway") in
1341 let entry4 = Newt.entry 16 13 None 16 [] in
1342 let label5 = Newt.label 4 14 (s_ "Nameserver") in
1343 let entry5 = Newt.entry 16 14 None 16 [] in
1345 let enable_static () =
1346 Newt.component_takes_focus entry1 true;
1347 Newt.component_takes_focus entry2 true;
1348 Newt.component_takes_focus entry3 true;
1349 Newt.component_takes_focus entry4 true;
1350 Newt.component_takes_focus entry5 true
1353 let disable_static () =
1354 Newt.component_takes_focus entry1 false;
1355 Newt.component_takes_focus entry2 false;
1356 Newt.component_takes_focus entry3 false;
1357 Newt.component_takes_focus entry4 false;
1358 Newt.component_takes_focus entry5 false
1361 let enable_autolist () =
1362 Newt.component_takes_focus
1363 (Newt.component_of_listbox autolist) true
1365 let disable_autolist () =
1366 Newt.component_takes_focus
1367 (Newt.component_of_listbox autolist) false
1371 Newt.component_add_callback auto
1372 (fun () ->disable_static (); enable_autolist ());
1373 Newt.component_add_callback shell
1374 (fun () -> disable_static (); disable_autolist ());
1375 Newt.component_add_callback qemu
1376 (fun () -> disable_static (); disable_autolist ());
1377 Newt.component_add_callback nonet
1378 (fun () -> disable_static (); disable_autolist ());
1379 Newt.component_add_callback static
1380 (fun () -> enable_static (); disable_autolist ());
1382 let ok = Newt.button 48 16 ok_button in
1384 let form = Newt.form None None [] in
1385 Newt.form_add_components form [auto;
1386 Newt.component_of_listbox autolist;
1387 shell;qemu;nonet;static;
1388 label1;label2;label3;label4;label5;
1389 entry1;entry2;entry3;entry4;entry5;
1394 ignore (Newt.run_form form);
1396 let r = Newt.radio_get_current auto in
1397 if Newt.component_equals r auto then (
1398 match Newt.listbox_get_current autolist with
1400 | Some part -> Auto part
1402 else if Newt.component_equals r shell then Shell
1403 else if Newt.component_equals r qemu then QEMUUserNet
1404 else if Newt.component_equals r nonet then NoNetwork
1405 else if Newt.component_equals r static then (
1406 let interface = Newt.entry_get_value entry1 in
1407 let address = Newt.entry_get_value entry2 in
1408 let netmask = Newt.entry_get_value entry3 in
1409 let gateway = Newt.entry_get_value entry4 in
1410 let nameserver = Newt.entry_get_value entry5 in
1411 if interface = "" || address = "" ||
1412 netmask = "" || gateway = "" then
1415 Static (interface, address, netmask, gateway, nameserver)
1424 config_transfer_type, config_network
1427 (* Try to bring up the network. *)
1428 (match config_network with
1430 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");
1433 | Static (interface, address, netmask, gateway, nameserver) ->
1434 print_endline (s_ "Trying static network configuration.\n");
1435 if not (static_network
1436 (interface, address, netmask, gateway, nameserver)) then (
1437 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");
1443 (s_ "Trying network auto-configuration from root filesystem ...\n");
1445 (* Mount the root filesystem read-only under /mnt/root. *)
1446 sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");
1448 if not (auto_network ()) then (
1449 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");
1453 (* NB. Lazy unmount is required because dhclient keeps its current
1454 * directory open on /etc/sysconfig/network-scripts/
1456 sh ("umount -l /mnt/root");
1459 print_endline (s_ "Trying QEMU network configuration.\n");
1462 | NoNetwork -> (* this is easy ... *) ()
1465 (* SSH configuration phase. *)
1469 match !config_ssh with
1472 (* Query the user for SSH configuration. *)
1473 open_centered_window ~stage:(s_ "SSH configuration")
1474 60 20 (s_ "SSH configuration");
1476 let label1 = Newt.label 1 1 (s_ "Remote host") in
1477 let host = Newt.entry 20 1 None 36 [] in
1478 let label2 = Newt.label 1 2 (s_ "Remote port") in
1479 let port = Newt.entry 20 2 (Some "22") 6 [] in
1480 let label3 = Newt.label 1 3 (s_ "Remote directory") in
1481 let dir = Newt.entry 20 3 (Some "/var/lib/xen/images") 36 [] in
1482 let label4 = Newt.label 1 4 (s_ "SSH username") in
1483 let user = Newt.entry 20 4 (Some "root") 16 [] in
1485 There's no sensible way to support this for SSH:
1486 let label5 = Newt.label 1 5 (s_ "SSH password") in
1487 let pass = Newt.entry 20 5 None 16 [Newt.PASSWORD] in
1491 Newt.checkbox 16 7 (s_ "Use SSH compression (not good for LANs)")
1495 Newt.checkbox 16 9 (s_ "Test SSH connection") '*' None in
1497 let ok = Newt.button 48 16 ok_button in
1499 let form = Newt.form None None [] in
1500 Newt.form_add_components form [label1;label2;label3;label4;
1507 ignore (Newt.run_form form);
1508 let host = Newt.entry_get_value host in
1509 let port = Newt.entry_get_value port in
1510 let dir = Newt.entry_get_value dir in
1511 let user = Newt.entry_get_value user in
1512 let compr = Newt.checkbox_get_value compr = '*' in
1513 let check = Newt.checkbox_get_value check = '*' in
1514 if host <> "" && port <> "" && user <> "" then
1515 { ssh_host = host; ssh_port = port; ssh_directory = dir;
1516 ssh_username = user;
1517 ssh_compression = compr;
1518 ssh_check = check; }
1528 (* If asked, check the SSH connection. *)
1529 if config_ssh.ssh_check then
1530 if not (test_ssh config_ssh) then
1531 failwith (s_ "SSH configuration failed");
1533 (* Devices and root partition and target configuration selection stage. *)
1534 let config_devices_to_send, config_root_filesystem, config_target =
1537 let config_devices_to_send =
1538 match !config_devices_to_send with
1541 let items = List.map (
1544 sprintf "%s (%.3f GB)" (dev_of_block_device dev)
1545 ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in
1547 ) all_block_devices in
1549 select_multiple ~stage:(s_ "Block devices")
1551 (s_ "Select block devices to send")
1554 let config_root_filesystem =
1555 match !config_root_filesystem with
1558 let items = List.map (
1559 fun (part, (_, nature)) ->
1561 sprintf "%s %s" (dev_of_partition part)
1562 (string_of_nature nature) in
1566 select_single ~stage:(s_ "Root filesystem") 60
1567 (s_ "Select root filesystem")
1571 match !config_target with
1574 open_centered_window ~stage:(s_ "Target system") 40 20
1575 (s_ "Configure target system");
1577 let hvlabel = Newt.label 1 1 (s_ "Hypervisor:") in
1578 let hvlistbox = Newt.listbox 16 1 4 [Newt.SCROLL] in
1579 Newt.listbox_append_entry hvlistbox "Xen" (Some Xen);
1580 Newt.listbox_append_entry hvlistbox "QEMU" (Some QEMU);
1581 Newt.listbox_append_entry hvlistbox "KVM" (Some KVM);
1582 Newt.listbox_append_entry hvlistbox "Other" None;
1584 let archlabel = Newt.label 1 5 (s_ "Architecture:") in
1585 let archlistbox = Newt.listbox 16 5 4 [Newt.SCROLL] in
1586 Newt.listbox_append_entry archlistbox "i386" I386;
1587 Newt.listbox_append_entry archlistbox
1588 "x86-64 (64-bit x86)" X86_64;
1589 Newt.listbox_append_entry archlistbox "IA64 (Itanium)" IA64;
1590 Newt.listbox_append_entry archlistbox "PowerPC 32-bit" PPC;
1591 Newt.listbox_append_entry archlistbox "PowerPC 64-bit" PPC64;
1592 Newt.listbox_append_entry archlistbox "SPARC 32-bit" SPARC;
1593 Newt.listbox_append_entry archlistbox "SPARC 64-bit" SPARC64;
1594 Newt.listbox_append_entry archlistbox "Unknown/other" UnknownArch;
1596 (* Get the architecture of the selected root filesystem.
1597 * If not known, default to UnknownArch.
1599 Newt.listbox_set_current_by_key archlistbox UnknownArch;
1601 match List.assoc config_root_filesystem all_partitions with
1602 | _, LinuxRoot (arch, _) ->
1603 Newt.listbox_set_current_by_key archlistbox arch
1608 let memlabel = Newt.label 1 9 (s_ "Memory (MB):") in
1609 let mementry = Newt.entry 16 9
1610 (Some (string_of_int system_memory)) 8 [] in
1611 let cpulabel = Newt.label 1 10 (s_ "CPUs:") in
1612 let cpuentry = Newt.entry 16 10
1613 (Some (string_of_int system_nr_cpus)) 4 [] in
1614 let maclabel = Newt.label 1 11 (s_ "MAC addr:") in
1615 let macentry = Newt.entry 16 11 None 20 [] in
1617 Newt.label 1 12 (s_ "(leave MAC blank for random)") in
1620 Newt.checkbox 12 14 (s_ "Use remote libvirtd") '*' None in
1622 let ok = Newt.button 28 16 ok_button in
1624 let form = Newt.form None None [] in
1625 Newt.form_add_components form
1626 [hvlabel; Newt.component_of_listbox hvlistbox;
1627 archlabel; Newt.component_of_listbox archlistbox;
1630 maclabel; macentry; maclabel2;
1636 ignore (Newt.run_form form);
1638 let hv = Newt.listbox_get_current hvlistbox in
1639 let arch = Newt.listbox_get_current archlistbox in
1640 let mem = int_of_string (Newt.entry_get_value mementry) in
1641 let cpus = int_of_string (Newt.entry_get_value cpuentry) in
1642 let mac = Newt.entry_get_value macentry in
1643 let libvirtd = Newt.checkbox_get_value libvirtd = '*' in
1644 if hv <> None && arch <> None && mem >= 0 && cpus >= 0
1646 { tgt_hypervisor = Option.get hv;
1647 tgt_architecture = Option.get arch;
1648 tgt_memory = mem; tgt_vcpus = cpus;
1650 if mac <> "" then mac else random_mac_address ();
1651 tgt_libvirtd = libvirtd }
1655 Not_found | Failure "int_of_string" -> loop ()
1663 config_devices_to_send, config_root_filesystem, config_target
1666 (* If architecture is set to UnknownArch, then assume the same
1667 * architecture as the live CD.
1670 match config_target.tgt_architecture with
1672 let arch = shget "uname -m" in
1675 | Some (arch :: _) -> architecture_of_string arch
1676 | _ -> I386 (* probably wrong XXX *) in
1677 { config_target with tgt_architecture = arch }
1678 | _ -> config_target in
1680 (* Try to get the capabilities from the remote machine. If we fail
1681 * it doesn't matter too much.
1683 let caps_os_type, caps_emulator, caps_loader, caps_machine =
1685 if not config_target.tgt_libvirtd then raise Not_found;
1688 match config_target.tgt_hypervisor with
1689 | Some Xen -> "xen", "/"
1690 | Some (QEMU|KVM) -> "qemu", "/system"
1691 | None -> raise Not_found in
1693 sprintf "%s+ssh://%s@%s:%s%s"
1694 proto config_ssh.ssh_username
1695 config_ssh.ssh_host config_ssh.ssh_port path in
1696 eprintf "capabilities URI = %S\n%!" name;
1698 print_endline (s_ "Try to fetch remote hypervisor capabilities ...\n");
1700 let conn = Libvirt.Connect.connect_readonly ~name () in
1701 let caps = Libvirt.Connect.get_capabilities conn in
1702 Libvirt.Connect.close conn;
1704 (* Turn it into XML data. *)
1705 let caps = Xml.parse_string caps in
1706 eprintf "capabilities:\n%s\n%!" (Xml.to_string_fmt caps);
1708 (* We're looking for a guest with <os_type>hvm</os_type>
1709 * and <arch name="target-arch">... Later when we can
1710 * install PV drivers automatically, we will want to look
1711 * for paravirt guest types too.
1713 let guests = children_with_name "guest" caps in
1715 List.filter (xml_has_pcdata_child "os_type" "hvm") guests in
1716 let arch_str = string_of_architecture config_target.tgt_architecture in
1719 xml_has_child_matching (
1721 | Xml.Element (n, attribs, _)
1726 (* deal with i386 vs i686 pestilence *)
1727 architecture_of_string a = config_target.tgt_architecture
1734 (* In theory at this point we only have a single guest type
1735 * remaining. It might be that we have _zero_ available
1736 * guest types, which indicates probably an unsupported
1737 * capability of the remote hypervisor (or just that one of
1738 * many parsing or heuristics failed). It might be that
1739 * we have > 1 available guest types, which indicates some
1740 * feature we don't know about.
1742 let len = List.length guests in
1744 message_box (s_ "Warning")
1745 (sprintf (f_ "Remote hypervisor claims not to support fully virtualized %s guests.\n\nContinuing anyway.\n\n%!") arch_str);
1750 message_box (s_ "Note")
1751 (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)
1754 let guest = List.hd guests in
1757 try Some (find_pcdata_child "os_type" guest)
1758 with Not_found -> None in
1759 let arch_section = find_child_with_name "arch" guest in
1761 try Some (find_pcdata_child "emulator" arch_section)
1762 with Not_found -> None in
1764 try Some (find_pcdata_child "loader" arch_section)
1765 with Not_found -> None in
1767 try Some (find_pcdata_child "machine" arch_section)
1768 with Not_found -> None in
1770 os_type, emulator, loader, machine
1772 | Not_found -> None, None, None, None
1774 eprintf "XML error: %s\n%!" (Xml.error err);
1775 None, None, None, None
1776 | Xml.Not_element _ | Xml.Not_pcdata _ | Xml.No_attribute _ ->
1777 (* If these occur, need to add some more debugging. *)
1778 eprintf "XML error when parsing capabilities\n%!";
1779 None, None, None, None
1780 | Libvirt.Virterror err ->
1781 eprintf "libvirt error: %s\n%!" (Libvirt.Virterror.to_string err);
1782 None, None, None, None
1783 | Invalid_argument str ->
1784 eprintf "libvirt error: %s\n%!" str;
1785 None, None, None, None in
1787 (* In test mode, exit here before we do Bad Things to the developer's
1790 if test_dialog_stages then exit 1;
1792 print_endline (s_ "Performing LVM snapshots ...\n");
1794 (* Switch LVM config. *)
1796 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1797 sh "rm -f /etc/lvm/cache/.cache";
1798 sh "rm -f /etc/lvm.new/cache/.cache";
1800 (* Snapshot the block devices to send. *)
1801 let config_devices_to_send =
1804 let snapshot_dev = snapshot_name origin_dev in
1805 snapshot origin_dev snapshot_dev;
1806 (origin_dev, snapshot_dev)
1807 ) config_devices_to_send in
1809 (* Run kpartx on the snapshots. *)
1811 fun (origin, snapshot) ->
1812 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1813 ) config_devices_to_send;
1815 (* Rescan for LVs. *)
1819 (* Mount the root filesystem under /mnt/root. *)
1820 (match config_root_filesystem with
1822 let snapshot_dev = snapshot_name dev in
1823 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1826 (* The LV will be backed by a snapshot device, so just mount
1829 let dev = dev_of_partition lv in
1830 sh ("mount " ^ quote dev ^ " /mnt/root")
1833 (* Work out what devices will be called at the remote end and make
1834 * a map of original device to remapped device name. This is
1835 * quite simple for now: just map the devices to "hda", "hdb",
1836 * etc. (assuming full virt target for now).
1839 (* To generate "a", "b", ..., "aa", "ab", etc. The 'digits' are
1840 * stored in reverse.
1842 let num = ref ['a'] in
1843 let rec next_num_of num =
1845 | [] -> assert false
1846 | 'z' :: [] -> [ 'a'; 'a' ]
1847 | 'z' :: nums -> 'a' :: next_num_of nums
1848 | c :: nums -> Char.chr (Char.code c + 1) :: nums
1850 let get_hdX num = "hd" ^ String.implode (List.rev num) in
1853 fun (origin_dev, _) ->
1854 let remote_dev = get_hdX !num in
1855 num := next_num_of !num;
1856 (origin_dev, remote_dev)
1857 ) config_devices_to_send in
1859 (* Modify files on the root filesystem. *)
1860 rewrite_fstab remote_map;
1861 (* XXX Other files to rewrite? *)
1863 (* Unmount the root filesystem and sync disks. *)
1864 sh "umount /mnt/root";
1865 sh "sync"; (* Ugh, should be in stdlib. *)
1867 (* XXX This is using the hostname derived from network configuration
1868 * above. We might want to ask the user to choose.
1870 let hostname = safe_name (gethostname ()) in
1872 let date = sprintf "%04d%02d%02d%02d%02d"
1873 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1874 "p2v-" ^ hostname ^ "-" ^ date in
1876 (* Work out what the image filenames will be at the remote end. *)
1877 let config_devices_to_send = List.map (
1878 fun (origin_dev, snapshot_dev) ->
1879 let remote_dev = List.assoc origin_dev remote_map in
1880 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1881 (origin_dev, snapshot_dev, remote_dev, remote_name)
1882 ) config_devices_to_send in
1884 (* Write a configuration file. Not sure if this is any better than
1885 * just 'sprintf-ing' bits of XML text together, but at least we will
1886 * always get well-formed XML.
1888 * XXX There is a case for using virt-install to generate this XML.
1889 * When we start to incorporate libvirt access & storage API this
1890 * needs to be rethought.
1892 let conf_filename = basename ^ ".conf" in
1895 (* Shortcut to make "<name>value</name>". *)
1896 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1897 (* ... and the _other_ sort of leaf (god I hate XML). *)
1898 let tleaf name attribs = Xml.Element (name, attribs, []) in
1901 string_of_architecture config_target.tgt_architecture in
1903 wordsize_of_architecture config_target.tgt_architecture in
1905 (* Standard stuff for every domain. *)
1906 let name = leaf "name" hostname in
1907 let uuid = leaf "uuid" (random_uuid ()) in
1908 let maxmem, memory =
1909 let m = string_of_int (config_target.tgt_memory * 1024) in
1910 leaf "maxmem" m, leaf "memory" m in
1911 let vcpu = leaf "vcpu" (string_of_int config_target.tgt_vcpus) in
1913 (* Top-level stuff which differs for each HV type (isn't this supposed
1914 * to be portable ...)
1917 (* Use capabilities for os_type, etc. else use some good guesses. *)
1918 let os_type = Option.default "hvm" caps_os_type in
1919 let machine = Option.default "pc" caps_machine in
1920 let loader = Option.default "/usr/lib/xen/boot/hvmloader" caps_loader in
1922 match config_target.tgt_hypervisor with
1924 [Xml.Element ("os", [],
1925 [leaf "type" os_type;
1926 leaf "loader" loader;
1927 tleaf "boot" ["dev", "hd"]]);
1928 Xml.Element ("features", [],
1932 tleaf "clock" ["sync", "localtime"]]
1934 [Xml.Element ("os", [], [leaf "type" os_type]);
1935 tleaf "clock" ["sync", "localtime"]]
1937 [Xml.Element ("os", [],
1938 [Xml.Element ("type",
1940 "machine", machine],
1941 [Xml.PCData os_type]);
1942 tleaf "boot" ["dev", "hd"]])]
1946 (* <devices> section. *)
1949 match caps_emulator with
1950 (* Use the emulator from the libvirt capabilities. *)
1951 | Some s -> [leaf "emulator" s]
1953 (* If we don't have libvirt capabilities, best guess. *)
1954 match config_target.tgt_hypervisor with
1957 (if arch_wordsize = W64 then "/usr/lib64/xen/bin/qemu-dm"
1958 else "/usr/lib/xen/bin/qemu-dm")]
1960 [leaf "emulator" "/usr/bin/qemu"]
1962 [leaf "emulator" "/usr/bin/qemu-kvm"]
1966 Xml.Element ("interface", ["type", "user"],
1967 [tleaf "mac" ["address",
1968 config_target.tgt_mac_address]]) in
1969 (* XXX should have an option for Xen bridging:
1971 "interface", ["type","bridge"],
1972 [tleaf "source" ["bridge","xenbr0"];
1973 tleaf "mac" ["address",mac_address];
1974 tleaf "script" ["path","vif-bridge"]])*)
1975 let graphics = tleaf "graphics" ["type", "vnc"] in
1977 let disks = List.map (
1978 fun (_, _, remote_dev, remote_name) ->
1980 "disk", ["type", "file";
1982 [tleaf "source" ["file",
1983 config_ssh.ssh_directory ^ "/" ^ remote_name];
1984 tleaf "target" ["dev", remote_dev]]
1986 ) config_devices_to_send in
1990 emulator @ interface :: graphics :: disks
1993 (* Put it all together in <domain type='foo'>. *)
1996 (match config_target.tgt_hypervisor with
1997 | Some Xen -> ["type", "xen"]
1998 | Some QEMU -> ["type", "qemu"]
1999 | Some KVM -> ["type", "kvm"]
2001 name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
2004 (* Convert XML configuration file to a string, then send it to the
2008 let xml = Xml.to_string_fmt xml in
2011 match config_target.tgt_hypervisor with
2012 | Some Xen | None -> ""
2013 | Some QEMU | Some KVM -> " -c qemu:///system" in
2014 let xml = sprintf (f_ "\
2016 This is an automatically generated libvirt configuration file.
2017 It was written by the %s program.
2019 Please check the values in this configuration file carefully,
2020 particularly maxmem, memory, vcpu and any paths.
2022 To start the domain, do:
2025 -->\n\n") program_name conn_arg conf_filename conn_arg hostname
2029 let xml_len = String.length xml in
2030 eprintf "length of configuration file is %d bytes\n%!" xml_len;
2032 print_endline (s_ "\nWriting configuration file ...\n");
2034 let (sock,_) as conn = ssh_start_upload config_ssh conf_filename in
2035 (* In OCaml this actually loops calling write(2) *)
2036 ignore (write sock xml 0 xml_len);
2037 ssh_finish_upload conn in
2039 (* Send the device snapshots to the remote host. *)
2040 (* XXX This code should be made more robust against both network
2041 * errors and local I/O errors. Also should allow the user several
2042 * attempts to connect, or let them go back to the dialog stage.
2045 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
2046 eprintf "sending %s as %s\n%!"
2047 (dev_of_block_device origin_dev) remote_name;
2050 try List.assoc origin_dev all_block_devices
2051 with Not_found -> assert false (* internal error *) in
2054 printf (f_ "\nSending /dev/%s (%.3f GB) to remote machine\n\n%!")
2055 (dev_of_block_device origin_dev)
2056 ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in
2058 (* Open the snapshot device. *)
2059 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
2062 let (sock,_) as conn = ssh_start_upload config_ssh remote_name in
2064 (* Copy the data. *)
2065 let spinners = "|/-\\" (* "Oo" *) in
2066 let bufsize = 1024 * 1024 in
2067 let buffer = String.create bufsize in
2068 let start = gettimeofday () in
2070 let rec copy bytes_sent last_printed_at spinner =
2071 let n = read fd buffer 0 bufsize in
2073 let n' = write sock buffer 0 n in
2074 if n <> n' then assert false; (* never, according to the manual *)
2076 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
2077 let last_printed_at, spinner =
2078 let now = gettimeofday () in
2079 (* Print progress every few seconds. *)
2080 if now -. last_printed_at > 2. then (
2081 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
2082 let secs_elapsed = now -. start in
2083 printf "%.0f%% %c %.1f Mbps"
2084 (100. *. elapsed) spinners.[spinner]
2085 (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
2086 (* After 60 seconds has elapsed, start printing estimates. *)
2087 if secs_elapsed >= 60. then (
2088 let remaining = 1. -. elapsed in
2089 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
2090 if secs_remaining > 120. then
2091 printf (f_ " (about %.0f minutes remaining)")
2092 (secs_remaining/.60.)
2094 printf (f_ " (about %.0f seconds remaining)")
2098 let spinner = (spinner + 1) mod String.length spinners in
2101 else last_printed_at, spinner in
2103 copy bytes_sent last_printed_at spinner
2107 printf "\n\n%!"; (* because of the messages printed above *)
2110 ssh_finish_upload conn
2111 ) config_devices_to_send;
2113 (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
2115 (* Clean up and reboot. *)
2117 message_box (sprintf (f_ "%s has finished") program_name)
2118 (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.")
2119 config_ssh.ssh_directory conf_filename)
2127 (*----------------------------------------------------------------------*)
2130 let () = eprintf (f_ "usage: virt-p2v [--test] [ttyname]\n%!") in
2133 (* Make sure that exceptions from 'main' get printed out on stdout
2134 * as well as stderr, since stderr is probably redirected to the
2135 * logfile, and so not visible to the user.
2137 let handle_exn f arg =
2140 print_endline (Printexc.to_string exn);
2143 (* Test harness for the Makefile. The Makefile invokes this script as
2144 * 'virt-p2v --test' just to check it compiles. When it is running
2145 * from the actual live CD, there is a single parameter which is the
2146 * tty name (so usually 'virt-p2v tty1').
2149 match Array.to_list Sys.argv with
2150 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
2151 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
2152 | [ _; ttyname ] -> (* Run main with ttyname. *)
2153 handle_exn main (Some ttyname)
2154 | [ _ ] -> (* Interactive - no ttyname. *)
2155 handle_exn main None
2158 (* This file must end with a newline *)