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
54 type target_config = {
55 tgt_hypervisor : hypervisor option; (* Remote hypervisor. *)
56 tgt_architecture : architecture; (* Remote architecture. *)
57 tgt_memory : int; (* Memory (megabytes). *)
58 tgt_vcpus : int; (* Number of virtual CPUs. *)
59 tgt_mac_address : string; (* MAC address. *)
60 tgt_libvirtd : bool; (* True if libvirtd on remote. *)
63 (*----------------------------------------------------------------------*)
64 (* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section.
66 * If left as they are, then this will create a generic virt-p2v script
67 * which asks the user for each question. If you set the defaults here
68 * then you will get a custom virt-p2v which is partially or even fully
69 * automated and won't ask the user any questions.
71 * Note that 'None' means 'no default' (ie. ask the user) whereas
72 * 'Some foo' means use 'foo' as the answer.
74 * These are documented in the virt-p2v(1) manual page.
76 * After changing them, run './virt-p2v --test' to check syntax.
79 (* If greeting is true, wait for keypress after boot and during
80 * final verification. Set to 'false' for less interactions.
82 let config_greeting = ref true
84 (* General type of transfer. *)
85 let config_transfer_type = ref None
87 (* Network configuration. *)
88 let config_network = ref None
90 (* SSH configuration. *)
91 let config_ssh = ref None
93 (* What to transfer. *)
94 let config_devices_to_send = ref None
95 let config_root_filesystem = ref None
97 (* Configuration of the target. *)
98 let config_target = ref None
100 (* The name of the program as displayed in various places. *)
101 let program_name = "virt-p2v"
103 (* If you want to test the dialog stages, set this to true. *)
104 let test_dialog_stages = false
106 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
107 (*----------------------------------------------------------------------*)
109 (* Load external libraries. *)
112 #directory "+extlib";;
118 #directory "+xml-light";;
119 #load "xml-light.cma";;
126 (*----------------------------------------------------------------------*)
127 (* General helper functions. *)
129 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
130 let xs = List.sort ~cmp xs in
131 let rec loop = function
132 | [] -> [] | [x] -> [x]
133 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
134 | x :: xs -> x :: loop xs
138 let input_all_lines chan =
139 let lines = ref [] in
141 while true do lines := input_line chan :: !lines done; []
143 End_of_file -> List.rev !lines
145 let dev_of_partition = function
146 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
147 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
149 let string_of_architecture = function
156 | SPARC64 -> "sparc64"
157 | OtherArch arch -> arch
160 type nature = LinuxSwap
161 | LinuxRoot of architecture * linux_distro
162 | WindowsRoot (* Windows C: *)
163 | LinuxBoot (* Linux /boot *)
164 | NotRoot (* mountable, but not / or /boot *)
166 and linux_distro = RHEL of int * int
168 | Debian of int * int
171 let rec string_of_nature = function
172 | LinuxSwap -> "Linux swap"
173 | LinuxRoot (architecture, distro) ->
174 string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
175 | WindowsRoot -> "Windows root"
176 | LinuxBoot -> "Linux /boot"
177 | NotRoot -> "Mountable non-root"
178 | UnknownNature -> "Unknown"
179 and string_of_linux_distro = function
180 | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
181 | Fedora v -> sprintf "Fedora %d" v
182 | Debian (a,b) -> sprintf "Debian %d.%d" a b
183 | OtherLinux -> "Linux"
185 type ('a, 'b) either = Either of 'a | Or of 'b
187 (* We go into and out of newt mode at various stages, but we might
188 * also need to put up a message at any time. This keeps track of
189 * whether we are in newt mode or not.
191 * General tip: Try to do any complex operations like setting up the
192 * network or probing disks outside newt mode, and try not to throw
193 * exceptions in newt mode.
195 let in_newt = ref false
197 if !in_newt then f ()
201 try Either (Newt.init_and_finish f)
202 with exn -> Or exn in
204 match r with Either r -> r | Or exn -> raise exn
207 (* Clear the screen, open a new centered window, make sure the background
208 * and help messages are consistent.
210 let open_centered_window ?stage width height title =
211 if not !in_newt then failwith "open_centered_window: not in newt mode";
213 Newt.centered_window width height title;
215 program_name ^ (match stage with
217 | Some stage -> " - " ^ stage) in
218 Newt.draw_root_text 0 0 root_text;
219 Newt.push_help_line "F12 for next screen | [ALT] [F2] root / no password for shell"
221 (* Some general dialog boxes. *)
222 let message_box title text =
225 open_centered_window 40 20 title;
227 let textbox = Newt.textbox 1 1 36 14 [Newt.WRAP; Newt.SCROLL] in
228 Newt.textbox_set_text textbox text;
229 let ok = Newt.button 28 16 " OK " in
230 let form = Newt.form None None [] in
231 Newt.form_add_components form [textbox; ok];
233 Newt.component_takes_focus ok true;
235 ignore (Newt.run_form form);
239 (* Fail and exit with error. *)
242 let text = "\n" ^ text ^ "\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
243 message_box "Error" text;
246 (* Display a dialog with checkboxes, return the multiple selected items. *)
247 let select_multiple ?stage ?(force_one = false) width title items =
250 open_centered_window ?stage width 20 title;
254 fun i (label, handle, selected) ->
256 Newt.checkbox 1 (i+1) label
257 (if selected then '*' else ' ') None in
261 let ok = Newt.button 48 16 " OK " in
264 if List.length entries > 10 then
265 Some (Newt.vertical_scrollbar 58 1 10
266 Newt_int.NEWT_COLORSET_WINDOW
267 Newt_int.NEWT_COLORSET_ACTCHECKBOX)
270 let form = Newt.form vb None [] in
271 Newt.form_add_components form (List.map snd entries);
272 Newt.form_add_component form ok;
276 ignore (Newt.run_form form);
277 let selected = List.filter_map (
279 if Newt.checkbox_get_value cb = '*' then Some handle else None
281 if force_one && selected = [] then loop ()
291 (* Display a dialog with radio buttons, return the single selected item. *)
292 let select_single ?stage width title items =
293 if items = [] then failwith "select_single: no items";
297 open_centered_window ?stage width 20 title;
299 let prev = ref None in
302 fun i (label, handle) ->
303 let rb = Newt.radio_button 1 (i+1) label (!prev = None) !prev in
308 let ok = Newt.button (width-12) 16 " OK " in
311 if List.length entries > 10 then
312 Some (Newt.vertical_scrollbar 58 1 10
313 Newt_int.NEWT_COLORSET_WINDOW
314 Newt_int.NEWT_COLORSET_ACTCHECKBOX)
317 let form = Newt.form vb None [] in
318 Newt.form_add_components form (List.map snd entries);
319 Newt.form_add_component form ok;
323 ignore (Newt.run_form form);
324 let r = Option.get !prev in
325 let r = Newt.radio_get_current r in
326 (* Now we compare 'r' to all the 'rb's in the list
327 * to see which one is selected.
330 List.find (fun (_, rb) -> Newt.component_equals r rb) entries
341 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
342 let quote = Filename.quote
344 (* Run a shell command and check it returns 0. *)
346 eprintf "sh: %s\n%!" cmd;
347 if Sys.command cmd <> 0 then failwith (sprintf "Command failed:\n\n%s" cmd)
350 eprintf "shfailok: %s\n%!" cmd;
351 ignore (Sys.command cmd)
353 let shwithstatus cmd =
354 eprintf "shwithstatus: %s\n%!" cmd;
357 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
359 eprintf "shget: %s\n%!" cmd;
360 let chan = open_process_in cmd in
361 let lines = input_all_lines chan in
362 match close_process_in chan with
363 | WEXITED 0 -> Some lines (* command succeeded *)
364 | WEXITED _ -> None (* command failed *)
365 | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
366 | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
368 (* Start an interactive shell. Need to juggle file descriptors a bit
369 * because bash write PS1 to stderr (currently directed to the logfile).
373 | 0 -> (* child, runs bash *)
376 (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
378 Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
380 | _ -> (* parent, waits *)
381 eprintf "waiting for subshell to exit\n%!";
384 (* Some true if is dir/file, Some false if not, None if not found. *)
386 try Some ((stat path).st_kind = S_DIR)
387 with Unix_error (ENOENT, "stat", _) -> None
389 try Some ((stat path).st_kind = S_REG)
390 with Unix_error (ENOENT, "stat", _) -> None
392 (*----------------------------------------------------------------------*)
393 (* P2V-specific helper functions. *)
395 (* Generate a predictable safe name containing only letters, numbers
396 * and underscores. If passed a string with no letters or numbers,
397 * generates "_1", "_2", etc.
402 fun () -> incr i; "_" ^ string_of_int !i
405 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
406 let name = String.copy name in
407 let have_safe = ref false in
408 for i = 0 to String.length name - 1 do
409 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
411 if !have_safe then name else next_anon ()
413 type block_device = string * int64 (* "hda" & size in bytes *)
415 (* Parse the output of 'lvs' to get list of LV names, sizes,
416 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
419 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
423 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
427 let lines = List.map Pcre.split lines in
430 | [vg; lv; pvs; lvsize]
431 | [_; vg; lv; pvs; lvsize] ->
432 let pvs = String.nsplit pvs "," in
433 let pvs = List.filter_map (
436 let subs = Pcre.exec ~rex:devname pv in
437 Some (Pcre.get_substring subs 1)
440 eprintf "lvs: unexpected device name: %s\n%!" pv;
443 LV (vg, lv), pvs, lvsize
445 failwith ("lvs: unexpected output: " ^ String.concat "," line)
448 (* Get the partitions on a block device.
449 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
451 let get_partitions dev =
452 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
453 let devdir = "/sys/block/" ^ dev in
454 let parts = Sys.readdir devdir in
455 let parts = Array.to_list parts in
456 let parts = List.filter (
457 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
459 let parts = List.filter_map (
462 let subs = Pcre.exec ~rex part in
463 Some (Part (dev, Pcre.get_substring subs 1))
469 (* Generate snapshot device name from device name. *)
470 let snapshot_name dev =
471 "snap" ^ (safe_name dev)
473 (* Perform a device-mapper snapshot with ramdisk overlay. *)
475 let next_free_ram_disk =
477 fun () -> incr i; "/dev/ram" ^ string_of_int !i
479 fun origin_dev snapshot_dev ->
480 let ramdisk = next_free_ram_disk () in
482 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
483 let lines = shget cmd in
485 | Some (sectors::_) -> Int64.of_string sectors
487 failwith (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
489 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
490 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
491 snapshot_dev sectors origin_dev);
492 (* Create the snapshot. *)
493 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
494 snapshot_dev sectors snapshot_dev ramdisk)
496 (* Try to perform automatic network configuration, assuming a Fedora or
497 * RHEL-like root filesystem mounted on /mnt/root.
499 let auto_network () =
500 (* Fedora gives an error if this file doesn't exist. *)
501 sh "touch /etc/resolv.conf";
503 (* NB. Lazy unmount is required because dhclient keeps its current
504 * directory open on /etc/sysconfig/network-scripts/
505 * (Fixed in dhcp >= 4.0.0 but be generous anyway).
507 sh "mount -o bind /mnt/root/etc /etc";
508 let status = shwithstatus "/etc/init.d/network start" in
511 (* Try to ping the default gateway to see if this worked. *)
512 shfailok "ping -c3 `/sbin/ip route list match 0.0.0.0 | head -1 | awk '{print $3}'`";
514 if !config_greeting then (
515 printf "\n\nDid automatic network configuration work?\n";
516 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
518 let line = read_line () in
519 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
522 (* Non-interactive: return the status of /etc/init.d/network start. *)
525 (* Configure the network statically. *)
526 let static_network (interface, address, netmask, gateway, nameserver) =
527 let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
529 do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
530 (quote interface) (quote address) (quote netmask));
531 do_cmd_or_exit (sprintf "route add default gw %s %s"
532 (quote gateway) (quote interface));
533 if nameserver <> "" then
534 do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
538 Exit -> false (* failed *)
540 (* http://fabrice.bellard.free.fr/qemu/qemu-doc.html#SEC30 *)
541 let qemu_network () =
542 sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0";
543 sh "route add default gw 10.0.2.2 eth0";
544 sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"
546 (* Map local device names to remote devices names. At the moment we
547 * just change sd* to hd* (as device names appear under fullvirt). In
548 * future, lots of complex possibilities.
550 let remote_of_origin_dev =
551 let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
552 let devsd_subst = Pcre.subst "hd$1" in
554 Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
556 (* Make an SSH connection to the remote machine, execute command.
557 * The connection remains open until you call ssh_disconnect, it
558 * times out or there is some error.
560 * NB. The command is NOT quoted.
562 * Returns a pair (file descriptor, channel), both referring to the
563 * same thing. Use whichever is more convenient.
565 let ssh_connect config cmd =
566 let cmd = sprintf "ssh%s -l %s -p %s %s %s"
567 (if config.ssh_compression then " -C" else "")
568 (quote config.ssh_username) (quote config.ssh_port) (quote config.ssh_host)
570 eprintf "ssh_connect: %s\n%!" cmd;
571 let chan = open_process_out cmd in
572 descr_of_out_channel chan, chan
574 let ssh_disconnect (_, chan) =
575 eprintf "ssh_disconnect\n%!";
576 match close_process_out chan with
577 | WEXITED 0 -> () (* OK *)
578 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
579 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
580 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
582 (* Use these functions to upload a file. *)
583 let ssh_start_upload config filename =
585 sprintf "cat \\> %s/%s" (quote config.ssh_directory) (quote filename) in
586 ssh_connect config cmd
588 let ssh_finish_upload = ssh_disconnect
590 (* Test SSH connection. *)
591 let test_ssh config =
592 printf "Testing SSH connection by listing files in remote directory ...\n\n%!";
594 let cmd = sprintf "/bin/ls %s" (quote config.ssh_directory) in
595 let conn = ssh_connect config cmd in
598 if !config_greeting then (
599 printf "\n\nDid SSH work?\n";
600 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
602 let line = read_line () in
603 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
608 (* Rewrite /mnt/root/etc/fstab. *)
609 let rewrite_fstab devices_to_send =
610 let filename = "/mnt/root/etc/fstab" in
611 if is_file filename = Some true then (
612 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
614 let chan = open_in filename in
615 let lines = input_all_lines chan in
617 let lines = List.map Pcre.split lines in
618 let lines = List.map (
620 | dev :: rest when String.starts_with dev "/dev/" ->
621 let dev = String.sub dev 5 (String.length dev - 5) in
622 let dev = remote_of_origin_dev dev in
623 let dev = "/dev/" ^ dev in
628 let chan = open_out filename in
631 | [dev; mountpoint; fstype; options; freq; passno] ->
632 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
633 dev mountpoint fstype options freq passno
635 output_string chan (String.concat " " line);
636 output_char chan '\n'
641 (* Generate a random MAC address in the Xen-reserved space. *)
642 let random_mac_address () =
644 List.map (sprintf "%02x") (
645 List.map (fun _ -> Random.int 256) [0;0;0]
647 String.concat ":" ("00"::"16"::"3e"::random)
649 (* Generate a random UUID. *)
651 let hex = "0123456789abcdef" in
653 let str = String.create 32 in
654 for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
657 (*----------------------------------------------------------------------*)
658 (* Main entry point. *)
660 (* The general plan for the main function is to operate in stages:
665 * Information gathering about the system
666 * | (eg. block devices, number of CPUs, etc.)
668 * Greeting and type of transfer question
672 * | (after this point we have a working network)
675 * | (after this point we have a working SSH connection)
677 * Questions about what to transfer (block devs, root fs) <--.
680 * Questions about hypervisor configuration |
683 * Verify information -------- user wants to change info ----/
688 * Prior versions of virt-p2v (the ones which used 'dialog') had support
689 * for a back button so they could go back through dialogs. I removed
690 * this because it was hard to support and not particularly useful.
693 let rec main ttyname =
696 (* Running from an init script. We don't have much of a
697 * login environment, so set one up.
701 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
702 "/usr/bin"; "/bin"]);
703 putenv "HOME" "/root";
704 putenv "LOGNAME" "root";
706 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
709 (* Set up logging to /tmp/virt-p2v.log. *)
710 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
714 (* Log the start up time. *)
715 eprintf "\n\n**************************************************\n\n";
716 let tm = localtime (time ()) in
717 eprintf "%s starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
719 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
721 (* Connect stdin/stdout to the tty. *)
725 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
729 printf "%s starting up ...\n%!" program_name;
731 (* Disable screen blanking on tty. *)
732 sh "setterm -blank 0";
734 (* Check that the environment is a sane-looking live CD. If not, bail. *)
735 if not test_dialog_stages && is_dir "/mnt/root" <> Some true then
737 "You should only run this script from the live CD or a USB key.";
739 (* Start of the information gathering phase. *)
740 printf "Detecting hard drives (this may take some time) ...\n%!";
742 (* Search for all non-removable block devices. Do this early and bail
743 * if we can't find anything. This is a list of strings, like "hda".
745 let all_block_devices : block_device list =
746 let rex = Pcre.regexp "^[hs]d" in
747 let devices = Array.to_list (Sys.readdir "/sys/block") in
748 let devices = List.sort devices in
749 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
750 eprintf "all_block_devices: block devices: %s\n%!"
751 (String.concat "; " devices);
752 (* Run blockdev --getsize64 on each, and reject any where this fails
753 * (probably removable devices).
755 let devices = List.filter_map (
757 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
758 let lines = shget cmd in
760 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
761 | Some [] | None -> None
763 eprintf "all_block_devices: non-removable block devices: %s\n%!"
765 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
767 failwith "No non-removable block devices (hard disks, etc.) could be found on this machine.";
770 (* Search for partitions and LVs (anything that could contain a
771 * filesystem directly). We refer to these generically as
774 let all_partitions : partition list =
777 let lvs = get_lvs () in
778 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
779 let pvs = List.concat pvs in
780 let pvs = sort_uniq pvs in
781 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
782 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
783 eprintf "all_partitions: LVs: %s\n%!"
784 (String.concat "; " (List.map dev_of_partition lvs));
787 (* Partitions (eg. "sda1", "sda2"). *)
789 let parts = List.map fst all_block_devices in
790 let parts = List.map get_partitions parts in
791 let parts = List.concat parts in
792 eprintf "all_partitions: all partitions: %s\n%!"
793 (String.concat "; " (List.map dev_of_partition parts));
795 (* Remove any partitions which are PVs. *)
796 let parts = List.filter (
798 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
799 | LV _ -> assert false
802 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
803 (String.concat "; " (List.map dev_of_partition parts));
805 (* Concatenate LVs & Parts *)
808 (* Try to determine the nature of each partition.
809 * Root? Swap? Architecture? etc.
811 let all_partitions : (partition * nature) list =
812 (* Output of 'file' command for Linux swap file. *)
813 let swap = Pcre.regexp "Linux.*swap.*file" in
814 (* Contents of /etc/redhat-release. *)
815 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
816 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
817 (* Contents of /etc/debian_version. *)
818 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
819 (* Output of 'file' on certain executables. *)
820 let i386 = Pcre.regexp ", Intel 80386," in
821 let x86_64 = Pcre.regexp ", x86-64," in
822 let itanic = Pcre.regexp ", IA-64," in
824 (* Examine the filesystem mounted on 'mnt' to determine the
825 * operating system, and, if Linux, the distro.
828 if is_dir (mnt ^ "/Windows") = Some true &&
829 is_file (mnt ^ "/autoexec.bat") = Some true then
831 else if is_dir (mnt ^ "/etc") = Some true &&
832 is_dir (mnt ^ "/sbin") = Some true &&
833 is_dir (mnt ^ "/var") = Some true then (
834 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
835 let chan = open_in (mnt ^ "/etc/redhat-release") in
836 let lines = input_all_lines chan in
840 | [] -> (* empty /etc/redhat-release ...? *)
841 LinuxRoot (UnknownArch, OtherLinux)
842 | line::_ -> (* try to detect OS from /etc/redhat-release *)
844 let subs = Pcre.exec ~rex:rhel line in
845 let major = int_of_string (Pcre.get_substring subs 1) in
847 try int_of_string (Pcre.get_substring subs 2)
848 with Not_found -> 0 in
849 LinuxRoot (UnknownArch, RHEL (major, minor))
851 Not_found | Failure "int_of_string" ->
853 let subs = Pcre.exec ~rex:fedora line in
854 let version = int_of_string (Pcre.get_substring subs 1) in
855 LinuxRoot (UnknownArch, Fedora version)
857 Not_found | Failure "int_of_string" ->
858 LinuxRoot (UnknownArch, OtherLinux)
860 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
861 let chan = open_in (mnt ^ "/etc/debian_version") in
862 let lines = input_all_lines chan in
866 | [] -> (* empty /etc/debian_version ...? *)
867 LinuxRoot (UnknownArch, OtherLinux)
868 | line::_ -> (* try to detect version from /etc/debian_version *)
870 let subs = Pcre.exec ~rex:debian line in
871 let major = int_of_string (Pcre.get_substring subs 1) in
872 let minor = int_of_string (Pcre.get_substring subs 2) in
873 LinuxRoot (UnknownArch, Debian (major, minor))
875 Not_found | Failure "int_of_string" ->
876 LinuxRoot (UnknownArch, OtherLinux)
879 LinuxRoot (UnknownArch, OtherLinux)
880 ) else if is_dir (mnt ^ "/grub") = Some true &&
881 is_file (mnt ^ "/grub/stage1") = Some true then (
884 NotRoot (* mountable, but not a root filesystem *)
887 (* Examine the Linux root filesystem mounted on 'mnt' to
888 * determine the architecture. We do this by looking at some
889 * well-known binaries that we expect to be there.
891 let detect_architecture mnt =
892 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
894 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
895 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
896 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
902 let dev = dev_of_partition part in (* Get /dev device. *)
905 (* Use 'file' command to detect if it is swap. *)
906 let cmd = "file -sbL " ^ quote dev in
908 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
910 (* Blindly try to mount the device. *)
911 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
912 match shwithstatus cmd with
914 let os = detect_os "/mnt/root" in
917 | LinuxRoot (UnknownArch, distro) ->
918 let architecture = detect_architecture "/mnt/root" in
919 LinuxRoot (architecture, distro)
921 sh "umount /mnt/root";
924 | _ -> UnknownNature (* not mountable *)
928 eprintf "partition detection: %s is %s\n%!"
929 dev (string_of_nature nature);
935 printf "Finished detecting hard drives.\n%!";
937 (* Autodetect system memory. *)
939 let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
941 | Some (mem::_) -> int_of_float (float_of_string mem)
944 (* Autodetect system # pCPUs. *)
947 shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
949 | Some (cpus::_) -> int_of_string cpus
952 (* Greeting, type of transfer, network question stages.
953 * These are all done in newt mode.
955 let config_transfer_type, config_network =
959 if !config_greeting then
960 message_box program_name (sprintf "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);
962 (* Type of transfer. *)
963 let config_transfer_type =
964 match !config_transfer_type with
968 "Physical to Virtual (P2V)", P2V;
969 "Virtual to Virtual (V2V)", V2V;
972 select_single ~stage:"Transfer type" 40
976 (* Network configuration. *)
978 match !config_network with
981 open_centered_window ~stage:"Network"
982 60 20 "Configure network";
984 let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in
985 Newt.listbox_set_width autolist 52;
987 (* Populate the "Automatic" listbox with RHEL/Fedora
988 * root partitions found which allow us to do
989 * automatic configuration in a known way.
991 let rec loop = function
993 | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
997 (dev_of_partition partition)
998 (string_of_linux_distro distro) in
999 ignore (Newt.listbox_append_entry autolist label partition);
1001 | _ :: parts -> loop parts
1003 loop all_partitions;
1005 (* If there is no suitable root partition (the listbox
1006 * is empty) then disable the auto option and the listbox.
1008 let no_auto = Newt.listbox_item_count autolist = 0 in
1011 Newt.radio_button 1 1
1012 "Automatic from:" (not no_auto) None in
1014 Newt.radio_button 1 6
1015 "Start a shell" no_auto (Some auto) in
1018 Newt.component_takes_focus auto false;
1019 Newt.component_takes_focus
1020 (Newt.component_of_listbox autolist) false
1024 Newt.radio_button 1 7
1025 "QEMU user network" false (Some shell) in
1027 Newt.radio_button 1 8
1028 "No network or network already configured" false
1031 Newt.radio_button 1 9
1032 "Static configuration:" false (Some nonet) in
1034 let label1 = Newt.label 4 10 "Interface" in
1035 let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
1036 let label2 = Newt.label 4 11 "Address" in
1037 let entry2 = Newt.entry 16 11 None 16 [] in
1038 let label3 = Newt.label 4 12 "Netmask" in
1039 let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
1040 let label4 = Newt.label 4 13 "Gateway" in
1041 let entry4 = Newt.entry 16 13 None 16 [] in
1042 let label5 = Newt.label 4 14 "Nameserver" in
1043 let entry5 = Newt.entry 16 14 None 16 [] in
1045 let enable_static () =
1046 Newt.component_takes_focus entry1 true;
1047 Newt.component_takes_focus entry2 true;
1048 Newt.component_takes_focus entry3 true;
1049 Newt.component_takes_focus entry4 true;
1050 Newt.component_takes_focus entry5 true
1053 let disable_static () =
1054 Newt.component_takes_focus entry1 false;
1055 Newt.component_takes_focus entry2 false;
1056 Newt.component_takes_focus entry3 false;
1057 Newt.component_takes_focus entry4 false;
1058 Newt.component_takes_focus entry5 false
1061 let enable_autolist () =
1062 Newt.component_takes_focus
1063 (Newt.component_of_listbox autolist) true
1065 let disable_autolist () =
1066 Newt.component_takes_focus
1067 (Newt.component_of_listbox autolist) false
1071 Newt.component_add_callback auto
1072 (fun () ->disable_static (); enable_autolist ());
1073 Newt.component_add_callback shell
1074 (fun () -> disable_static (); disable_autolist ());
1075 Newt.component_add_callback qemu
1076 (fun () -> disable_static (); disable_autolist ());
1077 Newt.component_add_callback nonet
1078 (fun () -> disable_static (); disable_autolist ());
1079 Newt.component_add_callback static
1080 (fun () -> enable_static (); disable_autolist ());
1082 let ok = Newt.button 48 16 " OK " in
1084 let form = Newt.form None None [] in
1085 Newt.form_add_components form [auto;
1086 Newt.component_of_listbox autolist;
1087 shell;qemu;nonet;static;
1088 label1;label2;label3;label4;label5;
1089 entry1;entry2;entry3;entry4;entry5;
1094 ignore (Newt.run_form form);
1096 let r = Newt.radio_get_current auto in
1097 if Newt.component_equals r auto then (
1098 match Newt.listbox_get_current autolist with
1100 | Some part -> Auto part
1102 else if Newt.component_equals r shell then Shell
1103 else if Newt.component_equals r qemu then QEMUUserNet
1104 else if Newt.component_equals r nonet then NoNetwork
1105 else if Newt.component_equals r static then (
1106 let interface = Newt.entry_get_value entry1 in
1107 let address = Newt.entry_get_value entry2 in
1108 let netmask = Newt.entry_get_value entry3 in
1109 let gateway = Newt.entry_get_value entry4 in
1110 let nameserver = Newt.entry_get_value entry5 in
1111 if interface = "" || address = "" ||
1112 netmask = "" || gateway = "" then
1115 Static (interface, address, netmask, gateway, nameserver)
1124 config_transfer_type, config_network
1127 (* Try to bring up the network. *)
1128 (match config_network with
1130 printf "Network configuration.\n\n";
1131 printf "Please configure the network from this shell.\n\n";
1132 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1135 | Static (interface, address, netmask, gateway, nameserver) ->
1136 printf "Trying static network configuration.\n\n%!";
1137 if not (static_network
1138 (interface, address, netmask, gateway, nameserver)) then (
1139 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1140 printf "Please configure the network from this shell.\n\n";
1141 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1147 "Trying network auto-configuration from root filesystem ...\n\n%!";
1149 (* Mount the root filesystem read-only under /mnt/root. *)
1150 sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");
1152 if not (auto_network ()) then (
1153 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1154 printf "Please configure the network from this shell.\n\n";
1155 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1159 (* NB. Lazy unmount is required because dhclient keeps its current
1160 * directory open on /etc/sysconfig/network-scripts/
1162 sh ("umount -l /mnt/root");
1165 printf "Trying QEMU network configuration.\n\n%!";
1168 | NoNetwork -> (* this is easy ... *) ()
1171 (* SSH configuration phase. *)
1175 match !config_ssh with
1178 (* Query the user for SSH configuration. *)
1179 open_centered_window ~stage:"SSH configuration"
1180 60 20 "SSH configuration";
1182 let label1 = Newt.label 1 1 "Remote host" in
1183 let host = Newt.entry 20 1 None 36 [] in
1184 let label2 = Newt.label 1 2 "Remote port" in
1185 let port = Newt.entry 20 2 (Some "22") 6 [] in
1186 let label3 = Newt.label 1 3 "Remote directory" in
1187 let dir = Newt.entry 20 3 (Some "/var/lib/xen/images") 36 [] in
1188 let label4 = Newt.label 1 4 "SSH username" in
1189 let user = Newt.entry 20 4 (Some "root") 16 [] in
1191 There's no sensible way to support this for SSH:
1192 let label5 = Newt.label 1 5 "SSH password" in
1193 let pass = Newt.entry 20 5 None 16 [Newt.PASSWORD] in
1197 Newt.checkbox 16 7 "Use SSH compression (not good for LANs)"
1200 let check = Newt.checkbox 16 9 "Test SSH connection" '*' None in
1202 let ok = Newt.button 48 16 " OK " in
1204 let form = Newt.form None None [] in
1205 Newt.form_add_components form [label1;label2;label3;label4;
1212 ignore (Newt.run_form form);
1213 let host = Newt.entry_get_value host in
1214 let port = Newt.entry_get_value port in
1215 let dir = Newt.entry_get_value dir in
1216 let user = Newt.entry_get_value user in
1217 let compr = Newt.checkbox_get_value compr = '*' in
1218 let check = Newt.checkbox_get_value check = '*' in
1219 if host <> "" && port <> "" && user <> "" then
1220 { ssh_host = host; ssh_port = port; ssh_directory = dir;
1221 ssh_username = user;
1222 ssh_compression = compr;
1223 ssh_check = check; }
1233 (* If asked, check the SSH connection. *)
1234 if config_ssh.ssh_check then
1235 if not (test_ssh config_ssh) then
1236 failwith "SSH configuration failed";
1238 (* Devices and root partition and target configuration selection stage. *)
1239 let config_devices_to_send, config_root_filesystem, config_target =
1242 let config_devices_to_send =
1243 match !config_devices_to_send with
1246 let items = List.map (
1249 sprintf "/dev/%s (%.3f GB)" dev
1250 ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in
1252 ) all_block_devices in
1254 select_multiple ~stage:"Block devices" ~force_one:true 60
1255 "Select block devices to send"
1258 let config_root_filesystem =
1259 match !config_root_filesystem with
1262 let items = List.map (
1263 fun (part, nature) ->
1265 sprintf "%s %s" (dev_of_partition part)
1266 (string_of_nature nature) in
1270 select_single ~stage:"Root filesystem" 60
1271 "Select root filesystem"
1275 match !config_target with
1278 open_centered_window ~stage:"Target system" 40 20
1279 "Configure target system";
1281 let hvlabel = Newt.label 1 1 "Hypervisor:" in
1282 let hvlistbox = Newt.listbox 16 1 4 [Newt.SCROLL] in
1283 Newt.listbox_append_entry hvlistbox "Xen" (Some Xen);
1284 Newt.listbox_append_entry hvlistbox "QEMU" (Some QEMU);
1285 Newt.listbox_append_entry hvlistbox "KVM" (Some KVM);
1286 Newt.listbox_append_entry hvlistbox "Other" None;
1288 let archlabel = Newt.label 1 5 "Architecture:" in
1289 let archlistbox = Newt.listbox 16 5 4 [Newt.SCROLL] in
1290 Newt.listbox_append_entry archlistbox "i386" I386;
1291 Newt.listbox_append_entry archlistbox
1292 "x86-64 (64-bit x86)" X86_64;
1293 Newt.listbox_append_entry archlistbox "IA64 (Itanium)" IA64;
1294 Newt.listbox_append_entry archlistbox "PowerPC 32-bit" PPC;
1295 Newt.listbox_append_entry archlistbox "PowerPC 64-bit" PPC64;
1296 Newt.listbox_append_entry archlistbox "SPARC 32-bit" SPARC;
1297 Newt.listbox_append_entry archlistbox "SPARC 64-bit" SPARC64;
1298 Newt.listbox_append_entry archlistbox "Unknown/other" UnknownArch;
1300 (* Get the architecture of the selected root filesystem.
1301 * If not known, default to UnknownArch.
1303 Newt.listbox_set_current_by_key archlistbox UnknownArch;
1305 match List.assoc config_root_filesystem all_partitions with
1306 | LinuxRoot (arch, _) ->
1307 Newt.listbox_set_current_by_key archlistbox arch
1312 let memlabel = Newt.label 1 9 "Memory (MB):" in
1313 let mementry = Newt.entry 16 9
1314 (Some (string_of_int system_memory)) 8 [] in
1315 let cpulabel = Newt.label 1 10 "CPUs:" in
1316 let cpuentry = Newt.entry 16 10
1317 (Some (string_of_int system_nr_cpus)) 4 [] in
1318 let maclabel = Newt.label 1 11 "MAC addr:" in
1319 let macentry = Newt.entry 16 11 None 20 [] in
1320 let maclabel2 = Newt.label 1 12 "(leave MAC blank for random)" in
1323 Newt.checkbox 12 14 "Use remote libvirtd" '*' None in
1325 let ok = Newt.button 28 16 " OK " in
1327 let form = Newt.form None None [] in
1328 Newt.form_add_components form
1329 [hvlabel; Newt.component_of_listbox hvlistbox;
1330 archlabel; Newt.component_of_listbox archlistbox;
1333 maclabel; macentry; maclabel2;
1339 ignore (Newt.run_form form);
1341 let hv = Newt.listbox_get_current hvlistbox in
1342 let arch = Newt.listbox_get_current archlistbox in
1343 let mem = int_of_string (Newt.entry_get_value mementry) in
1344 let cpus = int_of_string (Newt.entry_get_value cpuentry) in
1345 let mac = Newt.entry_get_value macentry in
1346 let libvirtd = Newt.checkbox_get_value libvirtd = '*' in
1347 if hv <> None && arch <> None && mem >= 0 && cpus >= 0
1349 { tgt_hypervisor = Option.get hv;
1350 tgt_architecture = Option.get arch;
1351 tgt_memory = mem; tgt_vcpus = cpus;
1353 if mac <> "" then mac else random_mac_address ();
1354 tgt_libvirtd = libvirtd }
1358 Not_found | Failure "int_of_string" -> loop ()
1366 config_devices_to_send, config_root_filesystem, config_target
1369 (* In test mode, exit here before we do Bad Things to the developer's
1372 if test_dialog_stages then exit 1;
1374 (* Switch LVM config. *)
1376 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1377 sh "rm -f /etc/lvm/cache/.cache";
1378 sh "rm -f /etc/lvm.new/cache/.cache";
1380 (* Snapshot the block devices to send. *)
1381 let config_devices_to_send =
1384 let snapshot_dev = snapshot_name origin_dev in
1385 snapshot origin_dev snapshot_dev;
1386 (origin_dev, snapshot_dev)
1387 ) config_devices_to_send in
1389 (* Run kpartx on the snapshots. *)
1391 fun (origin, snapshot) ->
1392 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1393 ) config_devices_to_send;
1395 (* Rescan for LVs. *)
1399 (* Mount the root filesystem under /mnt/root. *)
1400 (match config_root_filesystem with
1401 | Part (dev, partnum) ->
1402 let dev = dev ^ partnum in
1403 let snapshot_dev = snapshot_name dev in
1404 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1407 (* The LV will be backed by a snapshot device, so just mount
1410 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1413 (* Work out what devices will be called at the remote end. *)
1414 let config_devices_to_send = List.map (
1415 fun (origin_dev, snapshot_dev) ->
1416 let remote_dev = remote_of_origin_dev origin_dev in
1417 (origin_dev, snapshot_dev, remote_dev)
1418 ) config_devices_to_send in
1420 (* Modify files on the root filesystem. *)
1421 rewrite_fstab config_devices_to_send;
1422 (* XXX Other files to rewrite? *)
1424 (* Unmount the root filesystem and sync disks. *)
1425 sh "umount /mnt/root";
1426 sh "sync"; (* Ugh, should be in stdlib. *)
1428 (* If architecture is set to UnknownArch, then assume the same
1429 * architecture as the live CD.
1432 match config_target.tgt_architecture with
1434 let arch = shget "uname -m" in
1437 | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
1438 | Some ("x86_64"::_) -> X86_64
1439 | Some ("ia64"::_) -> IA64
1440 | _ -> I386 (* probably wrong XXX *) in
1441 { config_target with tgt_architecture = arch }
1442 | _ -> config_target in
1444 (* XXX This is using the hostname derived from network configuration
1445 * above. We might want to ask the user to choose.
1447 let hostname = safe_name (gethostname ()) in
1449 let date = sprintf "%04d%02d%02d%02d%02d"
1450 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1451 "p2v-" ^ hostname ^ "-" ^ date in
1453 (* Work out what the image filenames will be at the remote end. *)
1454 let config_devices_to_send = List.map (
1455 fun (origin_dev, snapshot_dev, remote_dev) ->
1456 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1457 (origin_dev, snapshot_dev, remote_dev, remote_name)
1458 ) config_devices_to_send in
1460 (* Write a configuration file. Not sure if this is any better than
1461 * just 'sprintf-ing' bits of XML text together, but at least we will
1462 * always get well-formed XML.
1464 * XXX For some of the stuff here we really should do a
1465 * virConnectGetCapabilities call to the remote host first.
1467 * XXX There is a case for using virt-install to generate this XML.
1468 * When we start to incorporate libvirt access & storage API this
1469 * needs to be rethought.
1471 let conf_filename = basename ^ ".conf" in
1474 (* Shortcut to make "<name>value</name>". *)
1475 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1476 (* ... and the _other_ sort of leaf (god I hate XML). *)
1477 let tleaf name attribs = Xml.Element (name, attribs, []) in
1479 (* Standard stuff for every domain. *)
1480 let name = leaf "name" hostname in
1481 let uuid = leaf "uuid" (random_uuid ()) in
1482 let maxmem, memory =
1484 leaf "maxmem" (string_of_int (config_target.tgt_memory * 1024)) in
1486 let vcpu = leaf "vcpu" (string_of_int config_target.tgt_vcpus) in
1488 (* Top-level stuff which differs for each HV type (isn't this supposed
1489 * to be portable ...)
1492 match config_target.tgt_hypervisor with
1494 [Xml.Element ("os", [],
1496 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1497 tleaf "boot" ["dev", "hd"]]);
1498 Xml.Element ("features", [],
1502 tleaf "clock" ["sync", "localtime"]]
1504 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1505 tleaf "clock" ["sync", "localtime"]]
1507 [Xml.Element ("os", [],
1508 [Xml.Element ("type",
1510 string_of_architecture
1511 config_target.tgt_architecture;
1513 [Xml.PCData "hvm"]);
1514 tleaf "boot" ["dev", "hd"]])]
1518 (* <devices> section. *)
1521 match config_target.tgt_hypervisor with
1523 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1525 [leaf "emulator" "/usr/bin/qemu"]
1527 [leaf "emulator" "/usr/bin/qemu-kvm"]
1531 Xml.Element ("interface", ["type", "user"],
1532 [tleaf "mac" ["address",
1533 config_target.tgt_mac_address]]) in
1534 (* XXX should have an option for Xen bridging:
1536 "interface", ["type","bridge"],
1537 [tleaf "source" ["bridge","xenbr0"];
1538 tleaf "mac" ["address",mac_address];
1539 tleaf "script" ["path","vif-bridge"]])*)
1540 let graphics = tleaf "graphics" ["type", "vnc"] in
1542 let disks = List.map (
1543 fun (_, _, remote_dev, remote_name) ->
1545 "disk", ["type", "file";
1547 [tleaf "source" ["file",
1548 config_ssh.ssh_directory ^ "/" ^ remote_name];
1549 tleaf "target" ["dev", remote_dev]]
1551 ) config_devices_to_send in
1555 emulator @ interface :: graphics :: disks
1558 (* Put it all together in <domain type='foo'>. *)
1561 (match config_target.tgt_hypervisor with
1562 | Some Xen -> ["type", "xen"]
1563 | Some QEMU -> ["type", "qemu"]
1564 | Some KVM -> ["type", "kvm"]
1566 name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
1569 (* Convert XML configuration file to a string, then send it to the
1573 let xml = Xml.to_string_fmt xml in
1576 match config_target.tgt_hypervisor with
1577 | Some Xen | None -> ""
1578 | Some QEMU | Some KVM -> " -c qemu:///system" in
1579 let xml = sprintf "\
1581 This is a libvirt configuration file.
1583 To start the domain, do:
1586 -->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in
1588 let xml_len = String.length xml in
1589 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1591 let (sock,_) as conn = ssh_start_upload config_ssh conf_filename in
1592 (* In OCaml this actually loops calling write(2) *)
1593 ignore (write sock xml 0 xml_len);
1594 ssh_finish_upload conn in
1596 (* Send the device snapshots to the remote host. *)
1597 (* XXX This code should be made more robust against both network
1598 * errors and local I/O errors. Also should allow the user several
1599 * attempts to connect, or let them go back to the dialog stage.
1602 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1603 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1606 try List.assoc origin_dev all_block_devices
1607 with Not_found -> assert false (* internal error *) in
1609 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1610 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1612 (* Open the snapshot device. *)
1613 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1616 let (sock,_) as conn = ssh_start_upload config_ssh remote_name in
1618 (* Copy the data. *)
1619 let spinners = "|/-\\" (* "Oo" *) in
1620 let bufsize = 1024 * 1024 in
1621 let buffer = String.create bufsize in
1622 let start = gettimeofday () in
1624 let rec copy bytes_sent last_printed_at spinner =
1625 let n = read fd buffer 0 bufsize in
1627 let n' = write sock buffer 0 n in
1628 if n <> n' then assert false; (* never, according to the manual *)
1630 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1631 let last_printed_at, spinner =
1632 let now = gettimeofday () in
1633 (* Print progress every few seconds. *)
1634 if now -. last_printed_at > 2. then (
1635 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1636 let secs_elapsed = now -. start in
1637 printf "%.0f%% %c %.1f Mbps"
1638 (100. *. elapsed) spinners.[spinner]
1639 (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
1640 (* After 60 seconds has elapsed, start printing estimates. *)
1641 if secs_elapsed >= 60. then (
1642 let remaining = 1. -. elapsed in
1643 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1644 if secs_remaining > 120. then
1645 printf " (about %.0f minutes remaining)" (secs_remaining/.60.)
1647 printf " (about %.0f seconds remaining)"
1651 let spinner = (spinner + 1) mod String.length spinners in
1654 else last_printed_at, spinner in
1656 copy bytes_sent last_printed_at spinner
1660 printf "\n\n%!"; (* because of the messages printed above *)
1663 ssh_finish_upload conn
1664 ) config_devices_to_send;
1666 (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
1668 (* Clean up and reboot. *)
1670 message_box (sprintf "%s completed" program_name)
1671 (sprintf "\nThe physical to virtual migration is complete.\n\nPlease verify the disk image(s) and configuration file on the remote host, and then start up the virtual machine by doing:\n\ncd %s\nvirsh define %s\n\nWhen you press [OK] this machine will reboot."
1672 config_ssh.ssh_directory conf_filename)
1680 (*----------------------------------------------------------------------*)
1683 eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
1686 (* Make sure that exceptions from 'main' get printed out on stdout
1687 * as well as stderr, since stderr is probably redirected to the
1688 * logfile, and so not visible to the user.
1690 let handle_exn f arg =
1693 print_endline (Printexc.to_string exn);
1696 (* Test harness for the Makefile. The Makefile invokes this script as
1697 * 'virt-p2v --test' just to check it compiles. When it is running
1698 * from the actual live CD, there is a single parameter which is the
1699 * tty name (so usually 'virt-p2v tty1').
1702 match Array.to_list Sys.argv with
1703 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1704 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1705 | [ _; ttyname ] -> (* Run main with ttyname. *)
1706 handle_exn main (Some ttyname)
1707 | [ _ ] -> (* Interactive - no ttyname. *)
1708 handle_exn main None
1711 (* This file must end with a newline *)