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 *)
43 | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
47 (*----------------------------------------------------------------------*)
48 (* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section.
50 * If left as they are, then this will create a generic virt-p2v script
51 * which asks the user for each question. If you set the defaults here
52 * then you will get a custom virt-p2v which is partially or even fully
53 * automated and won't ask the user any questions.
55 * Note that 'None' means 'no default' (ie. ask the user) whereas
56 * 'Some foo' means use 'foo' as the answer.
58 * These are documented in the virt-p2v(1) manual page.
60 * After changing them, run './virt-p2v --test' to check syntax.
63 (* If greeting is true, wait for keypress after boot and during
64 * final verification. Set to 'false' for less interactions.
66 let config_greeting = ref true
68 (* General type of transfer. *)
69 let config_transfer_type = ref None
71 (* Network configuration. *)
72 let config_network = ref None
74 (* SSH configuration. *)
75 let config_remote_host = ref None
76 let config_remote_port = ref None
77 let config_remote_directory = ref None
78 let config_remote_username = ref None
79 let config_remote_password = ref None
80 let config_ssh_check = ref None
81 let config_libvirtd_check = ref None
83 (* What to transfer. *)
84 let config_devices_to_send = ref None
85 let config_root_filesystem = ref None
87 (* Configuration of the target. *)
88 let config_hypervisor = ref None
89 let config_architecture = ref None
90 let config_memory = ref None
91 let config_vcpus = ref None
92 let config_mac_address = ref None
93 let config_compression = ref None
95 (* The name of the program as displayed in various places. *)
96 let program_name = "virt-p2v"
98 (* If you want to test the dialog stages, set this to true. *)
99 let test_dialog_stages = false
101 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
102 (*----------------------------------------------------------------------*)
104 (* Load external libraries. *)
107 #directory "+extlib";;
113 #directory "+xml-light";;
114 #load "xml-light.cma";;
121 (*----------------------------------------------------------------------*)
122 (* General helper functions. *)
124 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
125 let xs = List.sort ~cmp xs in
126 let rec loop = function
127 | [] -> [] | [x] -> [x]
128 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
129 | x :: xs -> x :: loop xs
133 let input_all_lines chan =
134 let lines = ref [] in
136 while true do lines := input_line chan :: !lines done; []
138 End_of_file -> List.rev !lines
140 let dev_of_partition = function
141 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
142 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
144 let string_of_architecture = function
151 | SPARC64 -> "sparc64"
152 | OtherArch arch -> arch
155 type nature = LinuxSwap
156 | LinuxRoot of architecture * linux_distro
157 | WindowsRoot (* Windows C: *)
158 | LinuxBoot (* Linux /boot *)
159 | NotRoot (* mountable, but not / or /boot *)
161 and linux_distro = RHEL of int * int
163 | Debian of int * int
166 let rec string_of_nature = function
167 | LinuxSwap -> "Linux swap"
168 | LinuxRoot (architecture, distro) ->
169 string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
170 | WindowsRoot -> "Windows root"
171 | LinuxBoot -> "Linux /boot"
172 | NotRoot -> "Mountable non-root"
173 | UnknownNature -> "Unknown"
174 and string_of_linux_distro = function
175 | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
176 | Fedora v -> sprintf "Fedora %d" v
177 | Debian (a,b) -> sprintf "Debian %d.%d" a b
178 | OtherLinux -> "Linux"
180 type ('a, 'b) either = Either of 'a | Or of 'b
182 (* We go into and out of newt mode at various stages, but we might
183 * also need to put up a message at any time. This keeps track of
184 * whether we are in newt mode or not.
186 * General tip: Try to do any complex operations like setting up the
187 * network or probing disks outside newt mode, and try not to throw
188 * exceptions in newt mode.
190 let in_newt = ref false
192 if !in_newt then f ()
196 try Either (Newt.init_and_finish f)
197 with exn -> Or exn in
199 match r with Either r -> r | Or exn -> raise exn
202 (* Clear the screen, open a new centered window, make sure the background
203 * and help messages are consistent.
205 let open_centered_window ?stage width height title =
206 if not !in_newt then failwith "open_centered_window: not in newt mode";
208 Newt.centered_window width height title;
210 program_name ^ (match stage with
212 | Some stage -> " - " ^ stage) in
213 Newt.draw_root_text 0 0 root_text;
214 Newt.push_help_line "F12 for next screen | [ALT] [F2] root / no password for shell"
216 (* Some general dialog boxes. *)
217 let message_box title text =
220 open_centered_window 40 20 title;
222 let textbox = Newt.textbox 1 1 36 14 [Newt.WRAP; Newt.SCROLL] in
223 Newt.textbox_set_text textbox text;
224 let ok = Newt.button 28 16 " OK " in
225 let form = Newt.form None None [] in
226 Newt.form_add_component form textbox;
227 Newt.form_add_component form ok;
229 Newt.component_takes_focus ok true;
231 ignore (Newt.run_form form);
235 (* Fail and exit with error. *)
238 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
239 message_box "Error" text;
242 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
243 let quote = Filename.quote
245 (* Run a shell command and check it returns 0. *)
247 eprintf "sh: %s\n%!" cmd;
248 if Sys.command cmd <> 0 then failwith (sprintf "Command failed:\n\n%s" cmd)
251 eprintf "shfailok: %s\n%!" cmd;
252 ignore (Sys.command cmd)
254 let shwithstatus cmd =
255 eprintf "shwithstatus: %s\n%!" cmd;
258 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
260 eprintf "shget: %s\n%!" cmd;
261 let chan = open_process_in cmd in
262 let lines = input_all_lines chan in
263 match close_process_in chan with
264 | WEXITED 0 -> Some lines (* command succeeded *)
265 | WEXITED _ -> None (* command failed *)
266 | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
267 | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
269 (* Start an interactive shell. Need to juggle file descriptors a bit
270 * because bash write PS1 to stderr (currently directed to the logfile).
274 | 0 -> (* child, runs bash *)
277 (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
279 Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
281 | _ -> (* parent, waits *)
282 eprintf "waiting for subshell to exit\n%!";
285 (* Some true if is dir/file, Some false if not, None if not found. *)
287 try Some ((stat path).st_kind = S_DIR)
288 with Unix_error (ENOENT, "stat", _) -> None
290 try Some ((stat path).st_kind = S_REG)
291 with Unix_error (ENOENT, "stat", _) -> None
293 (*----------------------------------------------------------------------*)
294 (* P2V-specific helper functions. *)
296 (* Generate a predictable safe name containing only letters, numbers
297 * and underscores. If passed a string with no letters or numbers,
298 * generates "_1", "_2", etc.
303 fun () -> incr i; "_" ^ string_of_int !i
306 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
307 let name = String.copy name in
308 let have_safe = ref false in
309 for i = 0 to String.length name - 1 do
310 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
312 if !have_safe then name else next_anon ()
314 type block_device = string * int64 (* "hda" & size in bytes *)
316 (* Parse the output of 'lvs' to get list of LV names, sizes,
317 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
320 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
324 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
328 let lines = List.map Pcre.split lines in
331 | [vg; lv; pvs; lvsize]
332 | [_; vg; lv; pvs; lvsize] ->
333 let pvs = String.nsplit pvs "," in
334 let pvs = List.filter_map (
337 let subs = Pcre.exec ~rex:devname pv in
338 Some (Pcre.get_substring subs 1)
341 eprintf "lvs: unexpected device name: %s\n%!" pv;
344 LV (vg, lv), pvs, lvsize
346 failwith ("lvs: unexpected output: " ^ String.concat "," line)
349 (* Get the partitions on a block device.
350 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
352 let get_partitions dev =
353 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
354 let devdir = "/sys/block/" ^ dev in
355 let parts = Sys.readdir devdir in
356 let parts = Array.to_list parts in
357 let parts = List.filter (
358 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
360 let parts = List.filter_map (
363 let subs = Pcre.exec ~rex part in
364 Some (Part (dev, Pcre.get_substring subs 1))
370 (* Generate snapshot device name from device name. *)
371 let snapshot_name dev =
372 "snap" ^ (safe_name dev)
374 (* Perform a device-mapper snapshot with ramdisk overlay. *)
376 let next_free_ram_disk =
378 fun () -> incr i; "/dev/ram" ^ string_of_int !i
380 fun origin_dev snapshot_dev ->
381 let ramdisk = next_free_ram_disk () in
383 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
384 let lines = shget cmd in
386 | Some (sectors::_) -> Int64.of_string sectors
388 failwith (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
390 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
391 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
392 snapshot_dev sectors origin_dev);
393 (* Create the snapshot. *)
394 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
395 snapshot_dev sectors snapshot_dev ramdisk)
397 (* Try to perform automatic network configuration, assuming a Fedora or
398 * RHEL-like root filesystem mounted on /mnt/root.
400 let auto_network () =
401 (* Fedora gives an error if this file doesn't exist. *)
402 sh "touch /etc/resolv.conf";
404 (* NB. Lazy unmount is required because dhclient keeps its current
405 * directory open on /etc/sysconfig/network-scripts/
407 sh "mount -o bind /mnt/root/etc /etc";
408 let status = shwithstatus "/etc/init.d/network start" in
411 (* Try to ping the default gateway to see if this worked. *)
412 shfailok "ping -c3 `/sbin/ip route list match 0.0.0.0 | head -1 | awk '{print $3}'`";
414 if !config_greeting then (
415 printf "\n\nDid automatic network configuration work?\n";
416 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
418 let line = read_line () in
419 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
422 (* Non-interactive: return the status of /etc/init.d/network start. *)
425 (* Configure the network statically. *)
426 let static_network (interface, address, netmask, gateway, nameserver) =
427 let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
429 do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
430 (quote interface) (quote address) (quote netmask));
431 do_cmd_or_exit (sprintf "route add default gw %s %s"
432 (quote gateway) (quote interface));
433 if nameserver <> "" then
434 do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
438 Exit -> false (* failed *)
440 (* http://fabrice.bellard.free.fr/qemu/qemu-doc.html#SEC30 *)
441 let qemu_network () =
442 sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0";
443 sh "route add default gw 10.0.2.2 eth0";
444 sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"
446 (* Map local device names to remote devices names. At the moment we
447 * just change sd* to hd* (as device names appear under fullvirt). In
448 * future, lots of complex possibilities.
450 let remote_of_origin_dev =
451 let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
452 let devsd_subst = Pcre.subst "hd$1" in
454 Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
456 (* Rewrite /mnt/root/etc/fstab. *)
457 let rewrite_fstab state devices_to_send =
458 let filename = "/mnt/root/etc/fstab" in
459 if is_file filename = Some true then (
460 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
462 let chan = open_in filename in
463 let lines = input_all_lines chan in
465 let lines = List.map Pcre.split lines in
466 let lines = List.map (
468 | dev :: rest when String.starts_with dev "/dev/" ->
469 let dev = String.sub dev 5 (String.length dev - 5) in
470 let dev = remote_of_origin_dev dev in
471 let dev = "/dev/" ^ dev in
476 let chan = open_out filename in
479 | [dev; mountpoint; fstype; options; freq; passno] ->
480 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
481 dev mountpoint fstype options freq passno
483 output_string chan (String.concat " " line);
484 output_char chan '\n'
489 (* Generate a random MAC address in the Xen-reserved space. *)
490 let random_mac_address () =
492 List.map (sprintf "%02x") (
493 List.map (fun _ -> Random.int 256) [0;0;0]
495 String.concat ":" ("00"::"16"::"3e"::random)
497 (* Generate a random UUID. *)
499 let hex = "0123456789abcdef" in
501 let str = String.create 32 in
502 for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
505 (*----------------------------------------------------------------------*)
506 (* Main entry point. *)
508 (* The general plan for the main function is to operate in stages:
513 * Information gathering about the system
514 * | (eg. block devices, number of CPUs, etc.)
516 * Greeting and type of transfer question
520 * | (after this point we have a working network)
523 * | (after this point we have a working SSH connection)
525 * Questions about what to transfer (block devs, root fs) <--.
528 * Questions about hypervisor configuration |
531 * Verify information -------- user wants to change info ----/
536 * Prior versions of virt-p2v (the ones which used 'dialog') had support
537 * for a back button so they could go back through dialogs. I removed
538 * this because it was hard to support and not particularly useful.
541 let rec main ttyname =
544 (* Running from an init script. We don't have much of a
545 * login environment, so set one up.
549 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
550 "/usr/bin"; "/bin"]);
551 putenv "HOME" "/root";
552 putenv "LOGNAME" "root";
554 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
557 (* Set up logging to /tmp/virt-p2v.log. *)
558 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
562 (* Log the start up time. *)
563 eprintf "\n\n**************************************************\n\n";
564 let tm = localtime (time ()) in
565 eprintf "%s starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
567 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
569 (* Connect stdin/stdout to the tty. *)
573 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
577 printf "%s starting up ...\n%!" program_name;
579 (* Disable screen blanking on tty. *)
580 sh "setterm -blank 0";
582 (* Check that the environment is a sane-looking live CD. If not, bail. *)
583 if not test_dialog_stages && is_dir "/mnt/root" <> Some true then
585 "You should only run this script from the live CD or a USB key.";
587 (* Start of the information gathering phase. *)
588 printf "%s detecting hard drives (this may take some time) ...\n%!"
591 (* Search for all non-removable block devices. Do this early and bail
592 * if we can't find anything. This is a list of strings, like "hda".
594 let all_block_devices : block_device list =
595 let rex = Pcre.regexp "^[hs]d" in
596 let devices = Array.to_list (Sys.readdir "/sys/block") in
597 let devices = List.sort devices in
598 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
599 eprintf "all_block_devices: block devices: %s\n%!"
600 (String.concat "; " devices);
601 (* Run blockdev --getsize64 on each, and reject any where this fails
602 * (probably removable devices).
604 let devices = List.filter_map (
606 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
607 let lines = shget cmd in
609 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
610 | Some [] | None -> None
612 eprintf "all_block_devices: non-removable block devices: %s\n%!"
614 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
616 failwith "No non-removable block devices (hard disks, etc.) could be found on this machine.";
619 (* Search for partitions and LVs (anything that could contain a
620 * filesystem directly). We refer to these generically as
623 let all_partitions : partition list =
626 let lvs = get_lvs () in
627 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
628 let pvs = List.concat pvs in
629 let pvs = sort_uniq pvs in
630 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
631 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
632 eprintf "all_partitions: LVs: %s\n%!"
633 (String.concat "; " (List.map dev_of_partition lvs));
636 (* Partitions (eg. "sda1", "sda2"). *)
638 let parts = List.map fst all_block_devices in
639 let parts = List.map get_partitions parts in
640 let parts = List.concat parts in
641 eprintf "all_partitions: all partitions: %s\n%!"
642 (String.concat "; " (List.map dev_of_partition parts));
644 (* Remove any partitions which are PVs. *)
645 let parts = List.filter (
647 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
648 | LV _ -> assert false
651 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
652 (String.concat "; " (List.map dev_of_partition parts));
654 (* Concatenate LVs & Parts *)
657 (* Try to determine the nature of each partition.
658 * Root? Swap? Architecture? etc.
660 let all_partitions : (partition * nature) list =
661 (* Output of 'file' command for Linux swap file. *)
662 let swap = Pcre.regexp "Linux.*swap.*file" in
663 (* Contents of /etc/redhat-release. *)
664 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
665 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
666 (* Contents of /etc/debian_version. *)
667 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
668 (* Output of 'file' on certain executables. *)
669 let i386 = Pcre.regexp ", Intel 80386," in
670 let x86_64 = Pcre.regexp ", x86-64," in
671 let itanic = Pcre.regexp ", IA-64," in
673 (* Examine the filesystem mounted on 'mnt' to determine the
674 * operating system, and, if Linux, the distro.
677 if is_dir (mnt ^ "/Windows") = Some true &&
678 is_file (mnt ^ "/autoexec.bat") = Some true then
680 else if is_dir (mnt ^ "/etc") = Some true &&
681 is_dir (mnt ^ "/sbin") = Some true &&
682 is_dir (mnt ^ "/var") = Some true then (
683 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
684 let chan = open_in (mnt ^ "/etc/redhat-release") in
685 let lines = input_all_lines chan in
689 | [] -> (* empty /etc/redhat-release ...? *)
690 LinuxRoot (UnknownArch, OtherLinux)
691 | line::_ -> (* try to detect OS from /etc/redhat-release *)
693 let subs = Pcre.exec ~rex:rhel line in
694 let major = int_of_string (Pcre.get_substring subs 1) in
696 try int_of_string (Pcre.get_substring subs 2)
697 with Not_found -> 0 in
698 LinuxRoot (UnknownArch, RHEL (major, minor))
700 Not_found | Failure "int_of_string" ->
702 let subs = Pcre.exec ~rex:fedora line in
703 let version = int_of_string (Pcre.get_substring subs 1) in
704 LinuxRoot (UnknownArch, Fedora version)
706 Not_found | Failure "int_of_string" ->
707 LinuxRoot (UnknownArch, OtherLinux)
709 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
710 let chan = open_in (mnt ^ "/etc/debian_version") in
711 let lines = input_all_lines chan in
715 | [] -> (* empty /etc/debian_version ...? *)
716 LinuxRoot (UnknownArch, OtherLinux)
717 | line::_ -> (* try to detect version from /etc/debian_version *)
719 let subs = Pcre.exec ~rex:debian line in
720 let major = int_of_string (Pcre.get_substring subs 1) in
721 let minor = int_of_string (Pcre.get_substring subs 2) in
722 LinuxRoot (UnknownArch, Debian (major, minor))
724 Not_found | Failure "int_of_string" ->
725 LinuxRoot (UnknownArch, OtherLinux)
728 LinuxRoot (UnknownArch, OtherLinux)
729 ) else if is_dir (mnt ^ "/grub") = Some true &&
730 is_file (mnt ^ "/grub/stage1") = Some true then (
733 NotRoot (* mountable, but not a root filesystem *)
736 (* Examine the Linux root filesystem mounted on 'mnt' to
737 * determine the architecture. We do this by looking at some
738 * well-known binaries that we expect to be there.
740 let detect_architecture mnt =
741 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
743 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
744 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
745 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
751 let dev = dev_of_partition part in (* Get /dev device. *)
754 (* Use 'file' command to detect if it is swap. *)
755 let cmd = "file -sbL " ^ quote dev in
757 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
759 (* Blindly try to mount the device. *)
760 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
761 match shwithstatus cmd with
763 let os = detect_os "/mnt/root" in
766 | LinuxRoot (UnknownArch, distro) ->
767 let architecture = detect_architecture "/mnt/root" in
768 LinuxRoot (architecture, distro)
770 sh "umount /mnt/root";
773 | _ -> UnknownNature (* not mountable *)
777 eprintf "partition detection: %s is %s\n%!"
778 dev (string_of_nature nature);
784 printf "finished detecting hard drives\n%!";
786 (* Autodetect system memory. *)
788 let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
790 | Some (mem::_) -> int_of_float (float_of_string mem)
793 (* Autodetect system # pCPUs. *)
796 shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
798 | Some (cpus::_) -> int_of_string cpus
801 (* Greeting, type of transfer, network question stages.
802 * These are all done in newt mode.
804 let config_transfer_type, config_network =
808 if !config_greeting then
809 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);
811 (* Type of transfer. *)
812 let config_transfer_type =
813 match !config_transfer_type with
817 open_centered_window ~stage:"Transfer type"
818 40 10 "Transfer type";
821 Newt.radio_button 1 1 "Physical to virtual (P2V)" true
824 Newt.radio_button 1 2 "Virtual to virtual (V2V)" false
826 let ok = Newt.button 28 6 " OK " in
828 let form = Newt.form None None [] in
829 Newt.form_add_components form [p2v; v2v];
830 Newt.form_add_component form ok;
832 ignore (Newt.run_form form);
835 let r = Newt.radio_get_current p2v in
836 if Newt.component_equals r p2v then P2V
837 else if Newt.component_equals r v2v then V2V
842 (* Network configuration. *)
844 match !config_network with
848 open_centered_window ~stage:"Network"
849 60 20 "Configure network";
851 let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in
852 Newt.listbox_set_width autolist 52;
854 (* Populate the "Automatic" listbox with RHEL/Fedora
855 * root partitions found which allow us to do
856 * automatic configuration in a known way.
858 let partition_map = Hashtbl.create 13 in
859 let maplen = ref 1 in
860 let rec iloop = function
862 | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
866 (dev_of_partition partition)
867 (string_of_linux_distro distro) in
868 Hashtbl.add partition_map (!maplen) partition;
870 Newt.listbox_append_entry autolist label (!maplen)
874 | _ :: parts -> iloop parts
876 iloop all_partitions;
878 (* If there is no suitable root partition (the listbox
879 * is empty) then disable the auto option and the listbox.
881 let no_auto = Hashtbl.length partition_map = 0 in
884 Newt.radio_button 1 1
885 "Automatic from:" (not no_auto) None in
887 Newt.radio_button 1 6
888 "Start a shell" no_auto (Some auto) in
891 Newt.component_takes_focus auto false;
892 Newt.component_takes_focus autolist false
896 Newt.radio_button 1 7
897 "QEMU user network" false (Some shell) in
899 Newt.radio_button 1 8
900 "No network or network already configured" false
903 Newt.radio_button 1 9
904 "Static configuration:" false (Some nonet) in
906 let label1 = Newt.label 4 10 "Interface" in
907 let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
908 let label2 = Newt.label 4 11 "Address" in
909 let entry2 = Newt.entry 16 11 None 16 [] in
910 let label3 = Newt.label 4 12 "Netmask" in
911 let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
912 let label4 = Newt.label 4 13 "Gateway" in
913 let entry4 = Newt.entry 16 13 None 16 [] in
914 let label5 = Newt.label 4 14 "Nameserver" in
915 let entry5 = Newt.entry 16 14 None 16 [] in
917 let enable_static () =
918 Newt.component_takes_focus entry1 true;
919 Newt.component_takes_focus entry2 true;
920 Newt.component_takes_focus entry3 true;
921 Newt.component_takes_focus entry4 true;
922 Newt.component_takes_focus entry5 true
925 let disable_static () =
926 Newt.component_takes_focus entry1 false;
927 Newt.component_takes_focus entry2 false;
928 Newt.component_takes_focus entry3 false;
929 Newt.component_takes_focus entry4 false;
930 Newt.component_takes_focus entry5 false
933 let enable_autolist () =
934 Newt.component_takes_focus autolist true
936 let disable_autolist () =
937 Newt.component_takes_focus autolist false
941 Newt.component_add_callback auto
942 (fun () ->disable_static (); enable_autolist ());
943 Newt.component_add_callback shell
944 (fun () -> disable_static (); disable_autolist ());
945 Newt.component_add_callback qemu
946 (fun () -> disable_static (); disable_autolist ());
947 Newt.component_add_callback nonet
948 (fun () -> disable_static (); disable_autolist ());
949 Newt.component_add_callback static
950 (fun () -> enable_static (); disable_autolist ());
952 let ok = Newt.button 28 16 " OK " in
954 let form = Newt.form None None [] in
955 Newt.form_add_component form auto;
956 Newt.form_add_component form autolist;
957 Newt.form_add_components form [shell;qemu;nonet;static];
958 Newt.form_add_components form
959 [label1;label2;label3;label4;label5];
960 Newt.form_add_components form
961 [entry1;entry2;entry3;entry4;entry5];
962 Newt.form_add_component form ok;
964 ignore (Newt.run_form form);
967 let r = Newt.radio_get_current auto in
968 if Newt.component_equals r auto then (
969 match Newt.listbox_get_current autolist with
971 | Some i -> Auto (Hashtbl.find partition_map i)
973 else if Newt.component_equals r shell then Shell
974 else if Newt.component_equals r qemu then QEMUUserNet
975 else if Newt.component_equals r nonet then NoNetwork
976 else if Newt.component_equals r static then (
977 let interface = Newt.entry_get_value entry1 in
978 let address = Newt.entry_get_value entry2 in
979 let netmask = Newt.entry_get_value entry3 in
980 let gateway = Newt.entry_get_value entry4 in
981 let nameserver = Newt.entry_get_value entry5 in
982 if interface = "" || address = "" ||
983 netmask = "" || gateway = "" then
986 Static (interface, address, netmask, gateway, nameserver)
992 config_transfer_type, config_network
995 (* Try to bring up the network. *)
996 (match config_network with
998 printf "Network configuration.\n\n";
999 printf "Please configure the network from this shell.\n\n";
1000 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1003 | Static (interface, address, netmask, gateway, nameserver) ->
1004 printf "Trying static network configuration.\n\n%!";
1005 if not (static_network
1006 (interface, address, netmask, gateway, nameserver)) then (
1007 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1008 printf "Please configure the network from this shell.\n\n";
1009 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1015 "Trying network auto-configuration from root filesystem ...\n\n%!";
1017 (* Mount the root filesystem read-only under /mnt/root. *)
1018 sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");
1020 if not (auto_network ()) then (
1021 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1022 printf "Please configure the network from this shell.\n\n";
1023 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1027 (* NB. Lazy unmount is required because dhclient keeps its current
1028 * directory open on /etc/sysconfig/network-scripts/
1030 sh ("umount -l /mnt/root");
1033 printf "Trying QEMU network configuration.\n\n%!";
1036 | NoNetwork -> (* this is easy ... *) ()
1040 let ask_hostname state =
1042 inputbox "Remote host" "Remote host" 10 50
1043 (Option.default "" state.remote_host)
1045 | Yes [] -> Ask_again
1046 | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
1047 | No | Help | Error -> Ask_again
1051 let ask_port state =
1053 inputbox "Remote port" "Remote port" 10 50
1054 (Option.default "22" state.remote_port)
1056 | Yes ([]|""::_) -> Next { state with remote_port = Some "22" }
1057 | Yes (port::_) -> Next { state with remote_port = Some port }
1058 | No | Help | Error -> Ask_again
1062 let ask_directory state =
1063 let default_dir = "/var/lib/xen/images" in
1065 inputbox "Remote directory" "Remote directory" 10 50
1066 (Option.default default_dir state.remote_directory)
1068 | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir }
1069 | Yes (dir::_) -> Next { state with remote_directory = Some dir }
1070 | No | Help | Error -> Ask_again
1074 let ask_username state =
1075 let default_username = "root" in
1077 inputbox "Remote username" "Remote username for ssh access to server" 10 50
1078 (Option.default default_username state.remote_username)
1081 Next { state with remote_username = Some default_username }
1082 | Yes (user::_) -> Next { state with remote_username = Some user }
1083 | No | Help | Error -> Ask_again
1087 let ask_devices state =
1088 let selected_devices = Option.default [] state.devices_to_send in
1089 let devices = List.map (
1090 fun (dev, blksize) ->
1092 sprintf "/dev/%s (%.3f GB)" dev
1093 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
1094 List.mem dev selected_devices)
1095 ) all_block_devices in
1097 checklist "Devices" "Pick devices to send" 15 50 8 devices
1099 | Yes [] | No | Help | Error -> Ask_again
1100 | Yes devices -> Next { state with devices_to_send = Some devices }
1104 let ask_root state =
1105 let parts = List.mapi (
1106 fun i (part, nature) ->
1109 | LinuxSwap -> " (Linux swap)"
1110 | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
1111 | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
1112 | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
1113 | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
1114 | WindowsRoot -> " (Windows C:)"
1115 | LinuxBoot -> " (Linux /boot)"
1116 | NotRoot -> " (filesystem)"
1117 | UnknownNature -> "" in
1119 dev_of_partition part ^ descr,
1120 Some part = state.root_filesystem)
1123 radiolist "Root device"
1124 "Pick partition containing the root (/) filesystem" 18 70 9
1128 let (part, _) = List.nth all_partitions (int_of_string i) in
1129 Next { state with root_filesystem = Some part }
1130 | Yes [] | No | Help | Error -> Ask_again
1134 let ask_hypervisor state =
1136 radiolist "Hypervisor"
1137 "Choose hypervisor / virtualization system"
1139 "xen", "Xen", state.hypervisor = Some Xen;
1140 "qemu", "QEMU", state.hypervisor = Some QEMU;
1141 "kvm", "KVM", state.hypervisor = Some KVM;
1142 "other", "Other", state.hypervisor = None
1145 | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
1146 | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
1147 | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
1148 | Yes _ -> Next { state with hypervisor = None }
1149 | No | Help | Error -> Ask_again
1153 let ask_architecture state =
1155 radiolist "Architecture" "Machine architecture" 16 50 8 [
1156 "i386", "i386 and up (32 bit)", state.architecture = Some I386;
1157 "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
1158 "ia64", "Itanium IA64", state.architecture = Some IA64;
1159 "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
1160 "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
1161 "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
1162 "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
1163 "auto", "Auto-detect",
1164 state.architecture = None || state.architecture = Some UnknownArch;
1167 | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
1168 | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
1169 | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
1170 | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
1171 | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
1172 | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
1173 | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
1174 | Yes _ -> Next { state with architecture = Some UnknownArch }
1175 | No | Help | Error -> Ask_again
1179 let ask_memory state =
1181 inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
1183 (Option.map_default string_of_int "" state.memory)
1185 | Yes (""::_ | []) -> Next { state with memory = Some 0 }
1187 let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
1188 if mem < 0 || (mem > 0 && mem < 64) then Ask_again
1189 else Next { state with memory = Some mem }
1190 | No | Help | Error -> Ask_again
1194 let ask_vcpus state =
1196 inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
1198 (Option.map_default string_of_int "" state.vcpus)
1200 | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
1203 try int_of_string vcpus with Failure "int_of_string" -> -1 in
1204 if vcpus < 0 then Ask_again
1205 else Next { state with vcpus = Some vcpus }
1206 | No | Help | Error -> Ask_again
1210 let ask_mac_address state =
1212 inputbox "MAC address"
1213 "Network MAC address. Leave blank to use a random address." 10 50
1214 (Option.default "" state.mac_address)
1216 | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
1217 | Yes (mac :: _) -> Next { state with mac_address = Some mac }
1218 | No | Help | Error -> Ask_again
1222 let ask_compression state =
1224 radiolist "Network compression" "Enable network compression" 10 50 2 [
1225 "yes", "Yes, compress network traffic", state.compression <> Some false;
1226 "no", "No, don't compress", state.compression = Some false
1229 | Yes ("no"::_) -> Next { state with compression = Some false }
1230 | Yes _ -> Next { state with compression = Some true }
1231 | No | Help | Error -> Ask_again
1235 let ask_verify state =
1237 yesno "Verify and proceed"
1238 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
1251 (Option.default "" state.remote_host)
1252 (Option.default "" state.remote_port)
1253 (Option.default "" state.remote_directory)
1254 (match state.network with
1255 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
1256 | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net"
1258 (String.concat "," (Option.default [] state.devices_to_send))
1259 (Option.map_default dev_of_partition "" state.root_filesystem)
1260 (match state.hypervisor with
1261 | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
1262 | None -> "Other / not set")
1263 (match state.architecture with
1264 | Some UnknownArch -> "Auto-detect"
1265 | Some arch -> string_of_architecture arch | None -> "")
1266 (match state.memory with
1267 | Some 0 -> "Same as physical"
1268 | Some mem -> string_of_int mem ^ " MB" | None -> "")
1269 (match state.vcpus with
1270 | Some 0 -> "Same as physical"
1271 | Some vcpus -> string_of_int vcpus | None -> "")
1272 (match state.mac_address with
1273 | Some "" -> "Random" | Some mac -> mac | None -> "")
1274 (Option.default true state.compression)
1278 | Yes _ -> Next state
1280 | No | Help | Error -> Ask_again
1283 (* This is the list of dialogs, in order. The user can go forwards or
1284 * backwards through them.
1286 * The second parameter in each tuple is true if we need to skip
1287 * this dialog statically (info already supplied in 'defaults' above).
1289 * The third parameter in each tuple is a function that tests whether
1290 * this dialog should be skipped, given other parts of the current state.
1293 let dont_skip _ = false in
1295 ask_greeting, not defaults.greeting, dont_skip;
1296 ask_hostname, defaults.remote_host <> None, dont_skip;
1297 ask_port, defaults.remote_port <> None, dont_skip;
1298 ask_directory, defaults.remote_directory <> None, dont_skip;
1299 ask_username, defaults.remote_username <> None, dont_skip;
1300 ask_network, defaults.network <> None, dont_skip;
1301 ask_static_network_config,
1302 defaults.static_network_config <> None,
1303 (function { network = Some Static } -> false | _ -> true);
1304 ask_devices, defaults.devices_to_send <> None, dont_skip;
1305 ask_root, defaults.root_filesystem <> None, dont_skip;
1306 ask_hypervisor, defaults.hypervisor <> None, dont_skip;
1307 ask_architecture, defaults.architecture <> None, dont_skip;
1308 ask_memory, defaults.memory <> None, dont_skip;
1309 ask_vcpus, defaults.vcpus <> None, dont_skip;
1310 ask_mac_address, defaults.mac_address <> None, dont_skip;
1311 ask_compression, defaults.compression <> None, dont_skip;
1312 ask_verify, not defaults.greeting, dont_skip;
1315 (* Loop through the dialogs until we reach the end. *)
1316 let rec loop ?(back=false) posn state =
1317 eprintf "dialog loop: posn = %d, back = %b\n%!" posn back;
1318 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
1319 else if posn < 0 then loop 0 state
1321 let dlg, skip_static, skip_dynamic = dlgs.(posn) in
1322 if skip_static || skip_dynamic state then
1323 (* Skip this dialog. *)
1324 loop ~back (if back then posn-1 else posn+1) state
1327 match dlg state with
1328 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
1329 | Ask_again -> loop posn state (* Repeat the question. *)
1330 | Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *)
1334 let state = loop 0 defaults in
1336 eprintf "finished dialog loop\n%!";
1338 (* In test mode, exit here before we do bad things to the developer's
1341 if test_dialog_stages then exit 1;
1343 (* Switch LVM config. *)
1345 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1346 sh "rm -f /etc/lvm/cache/.cache";
1347 sh "rm -f /etc/lvm.new/cache/.cache";
1349 (* Snapshot the block devices to send. *)
1350 let devices_to_send = Option.get state.devices_to_send in
1351 let devices_to_send =
1354 let snapshot_dev = snapshot_name origin_dev in
1355 snapshot origin_dev snapshot_dev;
1356 (origin_dev, snapshot_dev)
1357 ) devices_to_send in
1359 (* Run kpartx on the snapshots. *)
1361 fun (origin, snapshot) ->
1362 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1365 (* Rescan for LVs. *)
1369 (* Mount the root filesystem under /mnt/root. *)
1370 let root_filesystem = Option.get state.root_filesystem in
1371 (match root_filesystem with
1372 | Part (dev, partnum) ->
1373 let dev = dev ^ partnum in
1374 let snapshot_dev = snapshot_name dev in
1375 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1378 (* The LV will be backed by a snapshot device, so just mount
1381 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1384 (* Work out what devices will be called at the remote end. *)
1385 let devices_to_send = List.map (
1386 fun (origin_dev, snapshot_dev) ->
1387 let remote_dev = remote_of_origin_dev origin_dev in
1388 (origin_dev, snapshot_dev, remote_dev)
1389 ) devices_to_send in
1391 (* Modify files on the root filesystem. *)
1392 rewrite_fstab state devices_to_send;
1393 (* XXX Other files to rewrite? *)
1395 (* Unmount the root filesystem and sync disks. *)
1396 sh "umount /mnt/root";
1397 sh "sync"; (* Ugh, should be in stdlib. *)
1399 (* Get architecture of root filesystem, detected previously. *)
1400 let system_architecture =
1402 (match List.assoc root_filesystem all_partitions with
1403 | LinuxRoot (arch, _) -> arch
1404 | _ -> raise Not_found
1408 (* None was detected before, so assume same as live CD. *)
1409 let arch = shget "uname -m" in
1411 | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
1412 | Some ("x86_64"::_) -> X86_64
1413 | Some ("ia64"::_) -> IA64
1414 | _ -> I386 (* probably wrong XXX *) in
1416 let remote_host = Option.get state.remote_host in
1417 let remote_port = Option.get state.remote_port in
1418 let remote_directory = Option.get state.remote_directory in
1419 let remote_username = Option.get state.remote_username in
1421 (* Functions to connect and disconnect from the remote system. *)
1422 let do_connect remote_name _ =
1423 let cmd = sprintf "ssh%s -l %s -p %s %s \"cat > %s/%s\""
1424 (if state.compression = Some false then "" else " -C")
1425 (quote remote_username) (quote remote_port) (quote remote_host)
1426 (quote remote_directory) (quote remote_name) in
1427 eprintf "connect: %s\n%!" cmd;
1428 let chan = open_process_out cmd in
1429 descr_of_out_channel chan, chan
1431 let do_disconnect (_, chan) =
1432 match close_process_out chan with
1433 | WEXITED 0 -> () (* OK *)
1434 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
1435 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
1436 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
1439 (* XXX This is using the hostname derived from network configuration
1440 * above. We might want to ask the user to choose.
1442 let hostname = safe_name (gethostname ()) in
1444 let date = sprintf "%04d%02d%02d%02d%02d"
1445 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1446 "p2v-" ^ hostname ^ "-" ^ date in
1448 (* Work out what the image filenames will be at the remote end. *)
1449 let devices_to_send = List.map (
1450 fun (origin_dev, snapshot_dev, remote_dev) ->
1451 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1452 (origin_dev, snapshot_dev, remote_dev, remote_name)
1453 ) devices_to_send in
1455 (* Write a configuration file. Not sure if this is any better than
1456 * just 'sprintf-ing' bits of XML text together, but at least we will
1457 * always get well-formed XML.
1459 * XXX For some of the stuff here we really should do a
1460 * virConnectGetCapabilities call to the remote host first.
1462 * XXX There is a case for using virt-install to generate this XML.
1463 * When we start to incorporate libvirt access & storage API this
1464 * needs to be rethought.
1466 let conf_filename = basename ^ ".conf" in
1469 match state.architecture with
1470 | Some UnknownArch | None -> system_architecture
1471 | Some arch -> arch in
1473 match state.memory with
1474 | Some 0 | None -> system_memory
1475 | Some memory -> memory in
1477 match state.vcpus with
1478 | Some 0 | None -> system_nr_cpus
1481 match state.mac_address with
1482 | Some "" | None -> random_mac_address ()
1483 | Some mac -> mac in
1486 (* Shortcut to make "<name>value</name>". *)
1487 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1488 (* ... and the _other_ sort of leaf (god I hate XML). *)
1489 let tleaf name attribs = Xml.Element (name, attribs, []) in
1491 (* Standard stuff for every domain. *)
1492 let name = leaf "name" hostname in
1493 let uuid = leaf "uuid" (random_uuid ()) in
1494 let maxmem = leaf "maxmem" (string_of_int (memory * 1024)) in
1495 let memory = leaf "memory" (string_of_int (memory * 1024)) in
1496 let vcpu = leaf "vcpu" (string_of_int vcpus) in
1498 (* Top-level stuff which differs for each HV type (isn't this supposed
1499 * to be portable ...)
1502 match state.hypervisor with
1504 [Xml.Element ("os", [],
1506 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1507 tleaf "boot" ["dev", "hd"]]);
1508 Xml.Element ("features", [],
1512 tleaf "clock" ["sync", "localtime"]]
1514 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1515 tleaf "clock" ["sync", "localtime"]]
1517 [Xml.Element ("os", [],
1518 [Xml.Element ("type",
1520 string_of_architecture architecture;
1522 [Xml.PCData "hvm"]);
1523 tleaf "boot" ["dev", "hd"]])]
1527 (* <devices> section. *)
1530 match state.hypervisor with
1532 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1534 [leaf "emulator" "/usr/bin/qemu"]
1536 [leaf "emulator" "/usr/bin/qemu-kvm"]
1540 Xml.Element ("interface", ["type", "user"],
1541 [tleaf "mac" ["address", mac_address]]) in
1542 (* XXX should have an option for Xen bridging:
1544 "interface", ["type","bridge"],
1545 [tleaf "source" ["bridge","xenbr0"];
1546 tleaf "mac" ["address",mac_address];
1547 tleaf "script" ["path","vif-bridge"]])*)
1548 let graphics = tleaf "graphics" ["type", "vnc"] in
1550 let disks = List.map (
1551 fun (_, _, remote_dev, remote_name) ->
1553 "disk", ["type", "file";
1555 [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1556 tleaf "target" ["dev", remote_dev]]
1558 ) devices_to_send in
1562 emulator @ interface :: graphics :: disks
1565 (* Put it all together in <domain type='foo'>. *)
1568 (match state.hypervisor with
1569 | Some Xen -> ["type", "xen"]
1570 | Some QEMU -> ["type", "qemu"]
1571 | Some KVM -> ["type", "kvm"]
1573 name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
1576 (* Convert XML configuration file to a string, then send it to the
1580 let xml = Xml.to_string_fmt xml in
1583 match state.hypervisor with
1584 | Some Xen | None -> ""
1585 | Some QEMU | Some KVM -> " -c qemu:///system" in
1586 let xml = sprintf "\
1588 This is a libvirt configuration file.
1590 To start the domain, do:
1593 -->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in
1595 let xml_len = String.length xml in
1596 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1598 let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1599 (* In OCaml this actually loops calling write(2) *)
1600 ignore (write sock xml 0 xml_len);
1601 do_disconnect conn in
1603 (* Send the device snapshots to the remote host. *)
1604 (* XXX This code should be made more robust against both network
1605 * errors and local I/O errors. Also should allow the user several
1606 * attempts to connect, or let them go back to the dialog stage.
1609 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1610 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1613 try List.assoc origin_dev all_block_devices
1614 with Not_found -> assert false (* internal error *) in
1616 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1617 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1619 (* Open the snapshot device. *)
1620 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1623 let (sock,_) as conn = do_connect remote_name size in
1625 (* Copy the data. *)
1626 let spinners = "|/-\\" (* "Oo" *) in
1627 let bufsize = 1024 * 1024 in
1628 let buffer = String.create bufsize in
1629 let start = gettimeofday () in
1631 let rec copy bytes_sent last_printed_at spinner =
1632 let n = read fd buffer 0 bufsize in
1634 let n' = write sock buffer 0 n in
1635 if n <> n' then assert false; (* never, according to the manual *)
1637 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1638 let last_printed_at, spinner =
1639 let now = gettimeofday () in
1640 (* Print progress every few seconds. *)
1641 if now -. last_printed_at > 2. then (
1642 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1643 let secs_elapsed = now -. start in
1644 printf "%.0f%% %c %.1f Mbps"
1645 (100. *. elapsed) spinners.[spinner]
1646 (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
1647 (* After 60 seconds has elapsed, start printing estimates. *)
1648 if secs_elapsed >= 60. then (
1649 let remaining = 1. -. elapsed in
1650 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1651 if secs_remaining > 120. then
1652 printf " (about %.0f minutes remaining)" (secs_remaining/.60.)
1654 printf " (about %.0f seconds remaining)"
1658 let spinner = (spinner + 1) mod String.length spinners in
1661 else last_printed_at, spinner in
1663 copy bytes_sent last_printed_at spinner
1667 printf "\n\n%!"; (* because of the messages printed above *)
1673 (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
1675 (* Clean up and reboot. *)
1677 msgbox (sprintf "%s completed" program_name)
1678 (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."
1679 remote_directory conf_filename)
1688 (*----------------------------------------------------------------------*)
1691 eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
1694 (* Make sure that exceptions from 'main' get printed out on stdout
1695 * as well as stderr, since stderr is probably redirected to the
1696 * logfile, and so not visible to the user.
1698 let handle_exn f arg =
1701 print_endline (Printexc.to_string exn);
1704 (* Test harness for the Makefile. The Makefile invokes this script as
1705 * 'virt-p2v --test' just to check it compiles. When it is running
1706 * from the actual live CD, there is a single parameter which is the
1707 * tty name (so usually 'virt-p2v tty1').
1710 match Array.to_list Sys.argv with
1711 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1712 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1713 | [ _; ttyname ] -> (* Run main with ttyname. *)
1714 handle_exn main (Some ttyname)
1715 | [ _ ] -> (* Interactive - no ttyname. *)
1716 handle_exn main None
1719 (* This file must end with a newline *)