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";;
111 (*#directory "+newt";;*)
112 #directory "/home/rjones/d/redhat/newt";;
114 #directory "+xml-light";;
115 #load "xml-light.cma";;
122 (*----------------------------------------------------------------------*)
123 (* General helper functions. *)
125 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
126 let xs = List.sort ~cmp xs in
127 let rec loop = function
128 | [] -> [] | [x] -> [x]
129 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
130 | x :: xs -> x :: loop xs
134 let input_all_lines chan =
135 let lines = ref [] in
137 while true do lines := input_line chan :: !lines done; []
139 End_of_file -> List.rev !lines
141 let dev_of_partition = function
142 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
143 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
145 let string_of_architecture = function
152 | SPARC64 -> "sparc64"
153 | OtherArch arch -> arch
156 type nature = LinuxSwap
157 | LinuxRoot of architecture * linux_distro
158 | WindowsRoot (* Windows C: *)
159 | LinuxBoot (* Linux /boot *)
160 | NotRoot (* mountable, but not / or /boot *)
162 and linux_distro = RHEL of int * int
164 | Debian of int * int
167 let rec string_of_nature = function
168 | LinuxSwap -> "Linux swap"
169 | LinuxRoot (architecture, distro) ->
170 string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
171 | WindowsRoot -> "Windows root"
172 | LinuxBoot -> "Linux /boot"
173 | NotRoot -> "Mountable non-root"
174 | UnknownNature -> "Unknown"
175 and string_of_linux_distro = function
176 | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
177 | Fedora v -> sprintf "Fedora %d" v
178 | Debian (a,b) -> sprintf "Debian %d.%d" a b
179 | OtherLinux -> "Linux"
181 type ('a, 'b) either = Either of 'a | Or of 'b
183 (* We go into and out of newt mode at various stages, but we might
184 * also need to put up a message at any time. This keeps track of
185 * whether we are in newt mode or not.
187 * General tip: Try to do any complex operations like setting up the
188 * network or probing disks outside newt mode, and try not to throw
189 * exceptions in newt mode.
191 let in_newt = ref false
193 if !in_newt then f ()
197 try Either (Newt.init_and_finish f)
198 with exn -> Or exn in
200 match r with Either r -> r | Or exn -> raise exn
203 (* Clear the screen, open a new centered window, make sure the background
204 * and help messages are consistent.
206 let open_centered_window ?stage width height title =
207 if not !in_newt then failwith "open_centered_window: not in newt mode";
209 Newt.centered_window width height title;
211 program_name ^ (match stage with
213 | Some stage -> " - " ^ stage) in
214 Newt.draw_root_text 0 0 root_text;
215 Newt.push_help_line "F12 for next screen | [ALT] [F2] root / no password for shell"
217 (* Some general dialog boxes. *)
218 let message_box title text =
221 open_centered_window 40 20 title;
223 let textbox = Newt.textbox 1 1 36 14 [Newt.WRAP; Newt.SCROLL] in
224 Newt.textbox_set_text textbox text;
225 let ok = Newt.button 28 16 " OK " in
226 let form = Newt.form None None [] in
227 Newt.form_add_component form textbox;
228 Newt.form_add_component form ok;
230 Newt.component_takes_focus ok true;
232 ignore (Newt.run_form form);
236 (* Fail and exit with error. *)
239 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
240 message_box "Error" text;
243 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
244 let quote = Filename.quote
246 (* Run a shell command and check it returns 0. *)
248 eprintf "sh: %s\n%!" cmd;
249 if Sys.command cmd <> 0 then failwith (sprintf "Command failed:\n\n%s" cmd)
252 eprintf "shfailok: %s\n%!" cmd;
253 ignore (Sys.command cmd)
255 let shwithstatus cmd =
256 eprintf "shwithstatus: %s\n%!" cmd;
259 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
261 eprintf "shget: %s\n%!" cmd;
262 let chan = open_process_in cmd in
263 let lines = input_all_lines chan in
264 match close_process_in chan with
265 | WEXITED 0 -> Some lines (* command succeeded *)
266 | WEXITED _ -> None (* command failed *)
267 | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
268 | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
270 (* Start an interactive shell. Need to juggle file descriptors a bit
271 * because bash write PS1 to stderr (currently directed to the logfile).
275 | 0 -> (* child, runs bash *)
278 (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
280 Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
282 | _ -> (* parent, waits *)
283 eprintf "waiting for subshell to exit\n%!";
286 (* Some true if is dir/file, Some false if not, None if not found. *)
288 try Some ((stat path).st_kind = S_DIR)
289 with Unix_error (ENOENT, "stat", _) -> None
291 try Some ((stat path).st_kind = S_REG)
292 with Unix_error (ENOENT, "stat", _) -> None
294 (*----------------------------------------------------------------------*)
295 (* P2V-specific helper functions. *)
297 (* Generate a predictable safe name containing only letters, numbers
298 * and underscores. If passed a string with no letters or numbers,
299 * generates "_1", "_2", etc.
304 fun () -> incr i; "_" ^ string_of_int !i
307 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
308 let name = String.copy name in
309 let have_safe = ref false in
310 for i = 0 to String.length name - 1 do
311 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
313 if !have_safe then name else next_anon ()
315 type block_device = string * int64 (* "hda" & size in bytes *)
317 (* Parse the output of 'lvs' to get list of LV names, sizes,
318 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
321 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
325 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
329 let lines = List.map Pcre.split lines in
332 | [vg; lv; pvs; lvsize]
333 | [_; vg; lv; pvs; lvsize] ->
334 let pvs = String.nsplit pvs "," in
335 let pvs = List.filter_map (
338 let subs = Pcre.exec ~rex:devname pv in
339 Some (Pcre.get_substring subs 1)
342 eprintf "lvs: unexpected device name: %s\n%!" pv;
345 LV (vg, lv), pvs, lvsize
347 failwith ("lvs: unexpected output: " ^ String.concat "," line)
350 (* Get the partitions on a block device.
351 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
353 let get_partitions dev =
354 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
355 let devdir = "/sys/block/" ^ dev in
356 let parts = Sys.readdir devdir in
357 let parts = Array.to_list parts in
358 let parts = List.filter (
359 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
361 let parts = List.filter_map (
364 let subs = Pcre.exec ~rex part in
365 Some (Part (dev, Pcre.get_substring subs 1))
371 (* Generate snapshot device name from device name. *)
372 let snapshot_name dev =
373 "snap" ^ (safe_name dev)
375 (* Perform a device-mapper snapshot with ramdisk overlay. *)
377 let next_free_ram_disk =
379 fun () -> incr i; "/dev/ram" ^ string_of_int !i
381 fun origin_dev snapshot_dev ->
382 let ramdisk = next_free_ram_disk () in
384 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
385 let lines = shget cmd in
387 | Some (sectors::_) -> Int64.of_string sectors
389 failwith (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
391 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
392 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
393 snapshot_dev sectors origin_dev);
394 (* Create the snapshot. *)
395 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
396 snapshot_dev sectors snapshot_dev ramdisk)
398 (* Try to perform automatic network configuration, assuming a Fedora or
399 * RHEL-like root filesystem mounted on /mnt/root.
401 let auto_network () =
402 (* Fedora gives an error if this file doesn't exist. *)
403 sh "touch /etc/resolv.conf";
405 (* NB. Lazy unmount is required because dhclient keeps its current
406 * directory open on /etc/sysconfig/network-scripts/
408 sh "mount -o bind /mnt/root/etc /etc";
409 let status = shwithstatus "/etc/init.d/network start" in
412 (* Try to ping the default gateway to see if this worked. *)
413 shfailok "ping -c3 `/sbin/ip route list match 0.0.0.0 | head -1 | awk '{print $3}'`";
415 if !config_greeting then (
416 printf "\n\nDid automatic network configuration work?\n";
417 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
419 let line = read_line () in
420 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
423 (* Non-interactive: return the status of /etc/init.d/network start. *)
426 (* Configure the network statically. *)
427 let static_network (interface, address, netmask, gateway, nameserver) =
428 let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
430 do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
431 (quote interface) (quote address) (quote netmask));
432 do_cmd_or_exit (sprintf "route add default gw %s %s"
433 (quote gateway) (quote interface));
434 if nameserver <> "" then
435 do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
439 Exit -> false (* failed *)
441 (* http://fabrice.bellard.free.fr/qemu/qemu-doc.html#SEC30 *)
442 let qemu_network () =
443 sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0";
444 sh "route add default gw 10.0.2.2 eth0";
445 sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"
447 (* Map local device names to remote devices names. At the moment we
448 * just change sd* to hd* (as device names appear under fullvirt). In
449 * future, lots of complex possibilities.
451 let remote_of_origin_dev =
452 let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
453 let devsd_subst = Pcre.subst "hd$1" in
455 Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
457 (* Rewrite /mnt/root/etc/fstab. *)
458 let rewrite_fstab state devices_to_send =
459 let filename = "/mnt/root/etc/fstab" in
460 if is_file filename = Some true then (
461 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
463 let chan = open_in filename in
464 let lines = input_all_lines chan in
466 let lines = List.map Pcre.split lines in
467 let lines = List.map (
469 | dev :: rest when String.starts_with dev "/dev/" ->
470 let dev = String.sub dev 5 (String.length dev - 5) in
471 let dev = remote_of_origin_dev dev in
472 let dev = "/dev/" ^ dev in
477 let chan = open_out filename in
480 | [dev; mountpoint; fstype; options; freq; passno] ->
481 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
482 dev mountpoint fstype options freq passno
484 output_string chan (String.concat " " line);
485 output_char chan '\n'
490 (* Generate a random MAC address in the Xen-reserved space. *)
491 let random_mac_address () =
493 List.map (sprintf "%02x") (
494 List.map (fun _ -> Random.int 256) [0;0;0]
496 String.concat ":" ("00"::"16"::"3e"::random)
498 (* Generate a random UUID. *)
500 let hex = "0123456789abcdef" in
502 let str = String.create 32 in
503 for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
506 (*----------------------------------------------------------------------*)
507 (* Main entry point. *)
509 (* The general plan for the main function is to operate in stages:
514 * Information gathering about the system
515 * | (eg. block devices, number of CPUs, etc.)
517 * Greeting and type of transfer question
521 * | (after this point we have a working network)
524 * | (after this point we have a working SSH connection)
526 * Questions about what to transfer (block devs, root fs) <--.
529 * Questions about hypervisor configuration |
532 * Verify information -------- user wants to change info ----/
537 * Prior versions of virt-p2v (the ones which used 'dialog') had support
538 * for a back button so they could go back through dialogs. I removed
539 * this because it was hard to support and not particularly useful.
542 let rec main ttyname =
545 (* Running from an init script. We don't have much of a
546 * login environment, so set one up.
550 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
551 "/usr/bin"; "/bin"]);
552 putenv "HOME" "/root";
553 putenv "LOGNAME" "root";
555 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
558 (* Set up logging to /tmp/virt-p2v.log. *)
559 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
563 (* Log the start up time. *)
564 eprintf "\n\n**************************************************\n\n";
565 let tm = localtime (time ()) in
566 eprintf "%s starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
568 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
570 (* Connect stdin/stdout to the tty. *)
574 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
578 printf "%s starting up ...\n%!" program_name;
580 (* Disable screen blanking on tty. *)
581 sh "setterm -blank 0";
583 (* Check that the environment is a sane-looking live CD. If not, bail. *)
584 if not test_dialog_stages && is_dir "/mnt/root" <> Some true then
586 "You should only run this script from the live CD or a USB key.";
588 (* Start of the information gathering phase. *)
589 printf "%s detecting hard drives (this may take some time) ...\n%!"
592 (* Search for all non-removable block devices. Do this early and bail
593 * if we can't find anything. This is a list of strings, like "hda".
595 let all_block_devices : block_device list =
596 let rex = Pcre.regexp "^[hs]d" in
597 let devices = Array.to_list (Sys.readdir "/sys/block") in
598 let devices = List.sort devices in
599 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
600 eprintf "all_block_devices: block devices: %s\n%!"
601 (String.concat "; " devices);
602 (* Run blockdev --getsize64 on each, and reject any where this fails
603 * (probably removable devices).
605 let devices = List.filter_map (
607 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
608 let lines = shget cmd in
610 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
611 | Some [] | None -> None
613 eprintf "all_block_devices: non-removable block devices: %s\n%!"
615 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
617 failwith "No non-removable block devices (hard disks, etc.) could be found on this machine.";
620 (* Search for partitions and LVs (anything that could contain a
621 * filesystem directly). We refer to these generically as
624 let all_partitions : partition list =
627 let lvs = get_lvs () in
628 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
629 let pvs = List.concat pvs in
630 let pvs = sort_uniq pvs in
631 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
632 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
633 eprintf "all_partitions: LVs: %s\n%!"
634 (String.concat "; " (List.map dev_of_partition lvs));
637 (* Partitions (eg. "sda1", "sda2"). *)
639 let parts = List.map fst all_block_devices in
640 let parts = List.map get_partitions parts in
641 let parts = List.concat parts in
642 eprintf "all_partitions: all partitions: %s\n%!"
643 (String.concat "; " (List.map dev_of_partition parts));
645 (* Remove any partitions which are PVs. *)
646 let parts = List.filter (
648 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
649 | LV _ -> assert false
652 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
653 (String.concat "; " (List.map dev_of_partition parts));
655 (* Concatenate LVs & Parts *)
658 (* Try to determine the nature of each partition.
659 * Root? Swap? Architecture? etc.
661 let all_partitions : (partition * nature) list =
662 (* Output of 'file' command for Linux swap file. *)
663 let swap = Pcre.regexp "Linux.*swap.*file" in
664 (* Contents of /etc/redhat-release. *)
665 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
666 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
667 (* Contents of /etc/debian_version. *)
668 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
669 (* Output of 'file' on certain executables. *)
670 let i386 = Pcre.regexp ", Intel 80386," in
671 let x86_64 = Pcre.regexp ", x86-64," in
672 let itanic = Pcre.regexp ", IA-64," in
674 (* Examine the filesystem mounted on 'mnt' to determine the
675 * operating system, and, if Linux, the distro.
678 if is_dir (mnt ^ "/Windows") = Some true &&
679 is_file (mnt ^ "/autoexec.bat") = Some true then
681 else if is_dir (mnt ^ "/etc") = Some true &&
682 is_dir (mnt ^ "/sbin") = Some true &&
683 is_dir (mnt ^ "/var") = Some true then (
684 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
685 let chan = open_in (mnt ^ "/etc/redhat-release") in
686 let lines = input_all_lines chan in
690 | [] -> (* empty /etc/redhat-release ...? *)
691 LinuxRoot (UnknownArch, OtherLinux)
692 | line::_ -> (* try to detect OS from /etc/redhat-release *)
694 let subs = Pcre.exec ~rex:rhel line in
695 let major = int_of_string (Pcre.get_substring subs 1) in
697 try int_of_string (Pcre.get_substring subs 2)
698 with Not_found -> 0 in
699 LinuxRoot (UnknownArch, RHEL (major, minor))
701 Not_found | Failure "int_of_string" ->
703 let subs = Pcre.exec ~rex:fedora line in
704 let version = int_of_string (Pcre.get_substring subs 1) in
705 LinuxRoot (UnknownArch, Fedora version)
707 Not_found | Failure "int_of_string" ->
708 LinuxRoot (UnknownArch, OtherLinux)
710 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
711 let chan = open_in (mnt ^ "/etc/debian_version") in
712 let lines = input_all_lines chan in
716 | [] -> (* empty /etc/debian_version ...? *)
717 LinuxRoot (UnknownArch, OtherLinux)
718 | line::_ -> (* try to detect version from /etc/debian_version *)
720 let subs = Pcre.exec ~rex:debian line in
721 let major = int_of_string (Pcre.get_substring subs 1) in
722 let minor = int_of_string (Pcre.get_substring subs 2) in
723 LinuxRoot (UnknownArch, Debian (major, minor))
725 Not_found | Failure "int_of_string" ->
726 LinuxRoot (UnknownArch, OtherLinux)
729 LinuxRoot (UnknownArch, OtherLinux)
730 ) else if is_dir (mnt ^ "/grub") = Some true &&
731 is_file (mnt ^ "/grub/stage1") = Some true then (
734 NotRoot (* mountable, but not a root filesystem *)
737 (* Examine the Linux root filesystem mounted on 'mnt' to
738 * determine the architecture. We do this by looking at some
739 * well-known binaries that we expect to be there.
741 let detect_architecture mnt =
742 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
744 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
745 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
746 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
752 let dev = dev_of_partition part in (* Get /dev device. *)
755 (* Use 'file' command to detect if it is swap. *)
756 let cmd = "file -sbL " ^ quote dev in
758 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
760 (* Blindly try to mount the device. *)
761 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
762 match shwithstatus cmd with
764 let os = detect_os "/mnt/root" in
767 | LinuxRoot (UnknownArch, distro) ->
768 let architecture = detect_architecture "/mnt/root" in
769 LinuxRoot (architecture, distro)
771 sh "umount /mnt/root";
774 | _ -> UnknownNature (* not mountable *)
778 eprintf "partition detection: %s is %s\n%!"
779 dev (string_of_nature nature);
785 printf "finished detecting hard drives\n%!";
787 (* Autodetect system memory. *)
789 let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
791 | Some (mem::_) -> int_of_float (float_of_string mem)
794 (* Autodetect system # pCPUs. *)
797 shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
799 | Some (cpus::_) -> int_of_string cpus
802 (* Greeting, type of transfer, network question stages.
803 * These are all done in newt mode.
805 let config_transfer_type, config_network =
809 if !config_greeting then
810 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);
812 (* Type of transfer. *)
813 let config_transfer_type =
814 match !config_transfer_type with
818 open_centered_window ~stage:"Transfer type"
819 40 10 "Transfer type";
822 Newt.radio_button 1 1 "Physical to virtual (P2V)" true
825 Newt.radio_button 1 2 "Virtual to virtual (V2V)" false
827 let ok = Newt.button 28 6 " OK " in
829 let form = Newt.form None None [] in
830 Newt.form_add_components form [p2v; v2v];
831 Newt.form_add_component form ok;
833 ignore (Newt.run_form form);
836 let r = Newt.radio_get_current p2v in
837 if Newt.component_equals r p2v then P2V
838 else if Newt.component_equals r v2v then V2V
843 (* Network configuration. *)
845 match !config_network with
849 open_centered_window ~stage:"Network"
850 60 20 "Configure network";
852 let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in
853 Newt.listbox_set_width autolist 52;
855 (* Populate the "Automatic" listbox with RHEL/Fedora
856 * root partitions found which allow us to do
857 * automatic configuration in a known way.
859 let partition_map = Hashtbl.create 13 in
860 let maplen = ref 1 in
861 let rec iloop = function
863 | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
867 (dev_of_partition partition)
868 (string_of_linux_distro distro) in
869 Hashtbl.add partition_map (!maplen) partition;
871 Newt.listbox_append_entry autolist label (!maplen)
875 | _ :: parts -> iloop parts
877 iloop all_partitions;
879 (* If there is no suitable root partition (the listbox
880 * is empty) then disable the auto option and the listbox.
882 let no_auto = Hashtbl.length partition_map = 0 in
885 Newt.radio_button 1 1
886 "Automatic from:" (not no_auto) None in
888 Newt.radio_button 1 6
889 "Start a shell" no_auto (Some auto) in
892 Newt.component_takes_focus auto false;
893 Newt.component_takes_focus autolist false
897 Newt.radio_button 1 7
898 "QEMU user network" false (Some shell) in
900 Newt.radio_button 1 8
901 "No network or network already configured" false
904 Newt.radio_button 1 9
905 "Static configuration:" false (Some nonet) in
907 let label1 = Newt.label 4 10 "Interface" in
908 let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
909 let label2 = Newt.label 4 11 "Address" in
910 let entry2 = Newt.entry 16 11 None 16 [] in
911 let label3 = Newt.label 4 12 "Netmask" in
912 let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
913 let label4 = Newt.label 4 13 "Gateway" in
914 let entry4 = Newt.entry 16 13 None 16 [] in
915 let label5 = Newt.label 4 14 "Nameserver" in
916 let entry5 = Newt.entry 16 14 None 16 [] in
918 let enable_static () =
919 Newt.component_takes_focus entry1 true;
920 Newt.component_takes_focus entry2 true;
921 Newt.component_takes_focus entry3 true;
922 Newt.component_takes_focus entry4 true;
923 Newt.component_takes_focus entry5 true
926 let disable_static () =
927 Newt.component_takes_focus entry1 false;
928 Newt.component_takes_focus entry2 false;
929 Newt.component_takes_focus entry3 false;
930 Newt.component_takes_focus entry4 false;
931 Newt.component_takes_focus entry5 false
934 let enable_autolist () =
935 Newt.component_takes_focus autolist true
937 let disable_autolist () =
938 Newt.component_takes_focus autolist false
942 Newt.component_add_callback auto
943 (fun () ->disable_static (); enable_autolist ());
944 Newt.component_add_callback shell
945 (fun () -> disable_static (); disable_autolist ());
946 Newt.component_add_callback qemu
947 (fun () -> disable_static (); disable_autolist ());
948 Newt.component_add_callback nonet
949 (fun () -> disable_static (); disable_autolist ());
950 Newt.component_add_callback static
951 (fun () -> enable_static (); disable_autolist ());
953 let ok = Newt.button 28 16 " OK " in
955 let form = Newt.form None None [] in
956 Newt.form_add_component form auto;
957 Newt.form_add_component form autolist;
958 Newt.form_add_components form [shell;qemu;nonet;static];
959 Newt.form_add_components form
960 [label1;label2;label3;label4;label5];
961 Newt.form_add_components form
962 [entry1;entry2;entry3;entry4;entry5];
963 Newt.form_add_component form ok;
965 ignore (Newt.run_form form);
968 let r = Newt.radio_get_current auto in
969 if Newt.component_equals r auto then (
970 match Newt.listbox_get_current autolist with
972 | Some i -> Auto (Hashtbl.find partition_map i)
974 else if Newt.component_equals r shell then Shell
975 else if Newt.component_equals r qemu then QEMUUserNet
976 else if Newt.component_equals r nonet then NoNetwork
977 else if Newt.component_equals r static then (
978 let interface = Newt.entry_get_value entry1 in
979 let address = Newt.entry_get_value entry2 in
980 let netmask = Newt.entry_get_value entry3 in
981 let gateway = Newt.entry_get_value entry4 in
982 let nameserver = Newt.entry_get_value entry5 in
983 if interface = "" || address = "" ||
984 netmask = "" || gateway = "" then
987 Static (interface, address, netmask, gateway, nameserver)
993 config_transfer_type, config_network
996 (* Try to bring up the network. *)
997 (match config_network with
999 printf "Network configuration.\n\n";
1000 printf "Please configure the network from this shell.\n\n";
1001 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1004 | Static (interface, address, netmask, gateway, nameserver) ->
1005 printf "Trying static network configuration.\n\n%!";
1006 if not (static_network
1007 (interface, address, netmask, gateway, nameserver)) then (
1008 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1009 printf "Please configure the network from this shell.\n\n";
1010 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1016 "Trying network auto-configuration from root filesystem ...\n\n%!";
1018 (* Mount the root filesystem read-only under /mnt/root. *)
1019 sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");
1021 if not (auto_network ()) then (
1022 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1023 printf "Please configure the network from this shell.\n\n";
1024 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1028 (* NB. Lazy unmount is required because dhclient keeps its current
1029 * directory open on /etc/sysconfig/network-scripts/
1031 sh ("umount -l /mnt/root");
1034 printf "Trying QEMU network configuration.\n\n%!";
1037 | NoNetwork -> (* this is easy ... *) ()
1041 let ask_hostname state =
1043 inputbox "Remote host" "Remote host" 10 50
1044 (Option.default "" state.remote_host)
1046 | Yes [] -> Ask_again
1047 | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
1048 | No | Help | Error -> Ask_again
1052 let ask_port state =
1054 inputbox "Remote port" "Remote port" 10 50
1055 (Option.default "22" state.remote_port)
1057 | Yes ([]|""::_) -> Next { state with remote_port = Some "22" }
1058 | Yes (port::_) -> Next { state with remote_port = Some port }
1059 | No | Help | Error -> Ask_again
1063 let ask_directory state =
1064 let default_dir = "/var/lib/xen/images" in
1066 inputbox "Remote directory" "Remote directory" 10 50
1067 (Option.default default_dir state.remote_directory)
1069 | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir }
1070 | Yes (dir::_) -> Next { state with remote_directory = Some dir }
1071 | No | Help | Error -> Ask_again
1075 let ask_username state =
1076 let default_username = "root" in
1078 inputbox "Remote username" "Remote username for ssh access to server" 10 50
1079 (Option.default default_username state.remote_username)
1082 Next { state with remote_username = Some default_username }
1083 | Yes (user::_) -> Next { state with remote_username = Some user }
1084 | No | Help | Error -> Ask_again
1088 let ask_devices state =
1089 let selected_devices = Option.default [] state.devices_to_send in
1090 let devices = List.map (
1091 fun (dev, blksize) ->
1093 sprintf "/dev/%s (%.3f GB)" dev
1094 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
1095 List.mem dev selected_devices)
1096 ) all_block_devices in
1098 checklist "Devices" "Pick devices to send" 15 50 8 devices
1100 | Yes [] | No | Help | Error -> Ask_again
1101 | Yes devices -> Next { state with devices_to_send = Some devices }
1105 let ask_root state =
1106 let parts = List.mapi (
1107 fun i (part, nature) ->
1110 | LinuxSwap -> " (Linux swap)"
1111 | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
1112 | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
1113 | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
1114 | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
1115 | WindowsRoot -> " (Windows C:)"
1116 | LinuxBoot -> " (Linux /boot)"
1117 | NotRoot -> " (filesystem)"
1118 | UnknownNature -> "" in
1120 dev_of_partition part ^ descr,
1121 Some part = state.root_filesystem)
1124 radiolist "Root device"
1125 "Pick partition containing the root (/) filesystem" 18 70 9
1129 let (part, _) = List.nth all_partitions (int_of_string i) in
1130 Next { state with root_filesystem = Some part }
1131 | Yes [] | No | Help | Error -> Ask_again
1135 let ask_hypervisor state =
1137 radiolist "Hypervisor"
1138 "Choose hypervisor / virtualization system"
1140 "xen", "Xen", state.hypervisor = Some Xen;
1141 "qemu", "QEMU", state.hypervisor = Some QEMU;
1142 "kvm", "KVM", state.hypervisor = Some KVM;
1143 "other", "Other", state.hypervisor = None
1146 | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
1147 | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
1148 | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
1149 | Yes _ -> Next { state with hypervisor = None }
1150 | No | Help | Error -> Ask_again
1154 let ask_architecture state =
1156 radiolist "Architecture" "Machine architecture" 16 50 8 [
1157 "i386", "i386 and up (32 bit)", state.architecture = Some I386;
1158 "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
1159 "ia64", "Itanium IA64", state.architecture = Some IA64;
1160 "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
1161 "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
1162 "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
1163 "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
1164 "auto", "Auto-detect",
1165 state.architecture = None || state.architecture = Some UnknownArch;
1168 | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
1169 | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
1170 | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
1171 | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
1172 | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
1173 | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
1174 | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
1175 | Yes _ -> Next { state with architecture = Some UnknownArch }
1176 | No | Help | Error -> Ask_again
1180 let ask_memory state =
1182 inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
1184 (Option.map_default string_of_int "" state.memory)
1186 | Yes (""::_ | []) -> Next { state with memory = Some 0 }
1188 let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
1189 if mem < 0 || (mem > 0 && mem < 64) then Ask_again
1190 else Next { state with memory = Some mem }
1191 | No | Help | Error -> Ask_again
1195 let ask_vcpus state =
1197 inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
1199 (Option.map_default string_of_int "" state.vcpus)
1201 | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
1204 try int_of_string vcpus with Failure "int_of_string" -> -1 in
1205 if vcpus < 0 then Ask_again
1206 else Next { state with vcpus = Some vcpus }
1207 | No | Help | Error -> Ask_again
1211 let ask_mac_address state =
1213 inputbox "MAC address"
1214 "Network MAC address. Leave blank to use a random address." 10 50
1215 (Option.default "" state.mac_address)
1217 | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
1218 | Yes (mac :: _) -> Next { state with mac_address = Some mac }
1219 | No | Help | Error -> Ask_again
1223 let ask_compression state =
1225 radiolist "Network compression" "Enable network compression" 10 50 2 [
1226 "yes", "Yes, compress network traffic", state.compression <> Some false;
1227 "no", "No, don't compress", state.compression = Some false
1230 | Yes ("no"::_) -> Next { state with compression = Some false }
1231 | Yes _ -> Next { state with compression = Some true }
1232 | No | Help | Error -> Ask_again
1236 let ask_verify state =
1238 yesno "Verify and proceed"
1239 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
1252 (Option.default "" state.remote_host)
1253 (Option.default "" state.remote_port)
1254 (Option.default "" state.remote_directory)
1255 (match state.network with
1256 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
1257 | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net"
1259 (String.concat "," (Option.default [] state.devices_to_send))
1260 (Option.map_default dev_of_partition "" state.root_filesystem)
1261 (match state.hypervisor with
1262 | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
1263 | None -> "Other / not set")
1264 (match state.architecture with
1265 | Some UnknownArch -> "Auto-detect"
1266 | Some arch -> string_of_architecture arch | None -> "")
1267 (match state.memory with
1268 | Some 0 -> "Same as physical"
1269 | Some mem -> string_of_int mem ^ " MB" | None -> "")
1270 (match state.vcpus with
1271 | Some 0 -> "Same as physical"
1272 | Some vcpus -> string_of_int vcpus | None -> "")
1273 (match state.mac_address with
1274 | Some "" -> "Random" | Some mac -> mac | None -> "")
1275 (Option.default true state.compression)
1279 | Yes _ -> Next state
1281 | No | Help | Error -> Ask_again
1284 (* This is the list of dialogs, in order. The user can go forwards or
1285 * backwards through them.
1287 * The second parameter in each tuple is true if we need to skip
1288 * this dialog statically (info already supplied in 'defaults' above).
1290 * The third parameter in each tuple is a function that tests whether
1291 * this dialog should be skipped, given other parts of the current state.
1294 let dont_skip _ = false in
1296 ask_greeting, not defaults.greeting, dont_skip;
1297 ask_hostname, defaults.remote_host <> None, dont_skip;
1298 ask_port, defaults.remote_port <> None, dont_skip;
1299 ask_directory, defaults.remote_directory <> None, dont_skip;
1300 ask_username, defaults.remote_username <> None, dont_skip;
1301 ask_network, defaults.network <> None, dont_skip;
1302 ask_static_network_config,
1303 defaults.static_network_config <> None,
1304 (function { network = Some Static } -> false | _ -> true);
1305 ask_devices, defaults.devices_to_send <> None, dont_skip;
1306 ask_root, defaults.root_filesystem <> None, dont_skip;
1307 ask_hypervisor, defaults.hypervisor <> None, dont_skip;
1308 ask_architecture, defaults.architecture <> None, dont_skip;
1309 ask_memory, defaults.memory <> None, dont_skip;
1310 ask_vcpus, defaults.vcpus <> None, dont_skip;
1311 ask_mac_address, defaults.mac_address <> None, dont_skip;
1312 ask_compression, defaults.compression <> None, dont_skip;
1313 ask_verify, not defaults.greeting, dont_skip;
1316 (* Loop through the dialogs until we reach the end. *)
1317 let rec loop ?(back=false) posn state =
1318 eprintf "dialog loop: posn = %d, back = %b\n%!" posn back;
1319 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
1320 else if posn < 0 then loop 0 state
1322 let dlg, skip_static, skip_dynamic = dlgs.(posn) in
1323 if skip_static || skip_dynamic state then
1324 (* Skip this dialog. *)
1325 loop ~back (if back then posn-1 else posn+1) state
1328 match dlg state with
1329 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
1330 | Ask_again -> loop posn state (* Repeat the question. *)
1331 | Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *)
1335 let state = loop 0 defaults in
1337 eprintf "finished dialog loop\n%!";
1339 (* In test mode, exit here before we do bad things to the developer's
1342 if test_dialog_stages then exit 1;
1344 (* Switch LVM config. *)
1346 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1347 sh "rm -f /etc/lvm/cache/.cache";
1348 sh "rm -f /etc/lvm.new/cache/.cache";
1350 (* Snapshot the block devices to send. *)
1351 let devices_to_send = Option.get state.devices_to_send in
1352 let devices_to_send =
1355 let snapshot_dev = snapshot_name origin_dev in
1356 snapshot origin_dev snapshot_dev;
1357 (origin_dev, snapshot_dev)
1358 ) devices_to_send in
1360 (* Run kpartx on the snapshots. *)
1362 fun (origin, snapshot) ->
1363 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1366 (* Rescan for LVs. *)
1370 (* Mount the root filesystem under /mnt/root. *)
1371 let root_filesystem = Option.get state.root_filesystem in
1372 (match root_filesystem with
1373 | Part (dev, partnum) ->
1374 let dev = dev ^ partnum in
1375 let snapshot_dev = snapshot_name dev in
1376 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1379 (* The LV will be backed by a snapshot device, so just mount
1382 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1385 (* Work out what devices will be called at the remote end. *)
1386 let devices_to_send = List.map (
1387 fun (origin_dev, snapshot_dev) ->
1388 let remote_dev = remote_of_origin_dev origin_dev in
1389 (origin_dev, snapshot_dev, remote_dev)
1390 ) devices_to_send in
1392 (* Modify files on the root filesystem. *)
1393 rewrite_fstab state devices_to_send;
1394 (* XXX Other files to rewrite? *)
1396 (* Unmount the root filesystem and sync disks. *)
1397 sh "umount /mnt/root";
1398 sh "sync"; (* Ugh, should be in stdlib. *)
1400 (* Get architecture of root filesystem, detected previously. *)
1401 let system_architecture =
1403 (match List.assoc root_filesystem all_partitions with
1404 | LinuxRoot (arch, _) -> arch
1405 | _ -> raise Not_found
1409 (* None was detected before, so assume same as live CD. *)
1410 let arch = shget "uname -m" in
1412 | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
1413 | Some ("x86_64"::_) -> X86_64
1414 | Some ("ia64"::_) -> IA64
1415 | _ -> I386 (* probably wrong XXX *) in
1417 let remote_host = Option.get state.remote_host in
1418 let remote_port = Option.get state.remote_port in
1419 let remote_directory = Option.get state.remote_directory in
1420 let remote_username = Option.get state.remote_username in
1422 (* Functions to connect and disconnect from the remote system. *)
1423 let do_connect remote_name _ =
1424 let cmd = sprintf "ssh%s -l %s -p %s %s \"cat > %s/%s\""
1425 (if state.compression = Some false then "" else " -C")
1426 (quote remote_username) (quote remote_port) (quote remote_host)
1427 (quote remote_directory) (quote remote_name) in
1428 eprintf "connect: %s\n%!" cmd;
1429 let chan = open_process_out cmd in
1430 descr_of_out_channel chan, chan
1432 let do_disconnect (_, chan) =
1433 match close_process_out chan with
1434 | WEXITED 0 -> () (* OK *)
1435 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
1436 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
1437 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
1440 (* XXX This is using the hostname derived from network configuration
1441 * above. We might want to ask the user to choose.
1443 let hostname = safe_name (gethostname ()) in
1445 let date = sprintf "%04d%02d%02d%02d%02d"
1446 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1447 "p2v-" ^ hostname ^ "-" ^ date in
1449 (* Work out what the image filenames will be at the remote end. *)
1450 let devices_to_send = List.map (
1451 fun (origin_dev, snapshot_dev, remote_dev) ->
1452 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1453 (origin_dev, snapshot_dev, remote_dev, remote_name)
1454 ) devices_to_send in
1456 (* Write a configuration file. Not sure if this is any better than
1457 * just 'sprintf-ing' bits of XML text together, but at least we will
1458 * always get well-formed XML.
1460 * XXX For some of the stuff here we really should do a
1461 * virConnectGetCapabilities call to the remote host first.
1463 * XXX There is a case for using virt-install to generate this XML.
1464 * When we start to incorporate libvirt access & storage API this
1465 * needs to be rethought.
1467 let conf_filename = basename ^ ".conf" in
1470 match state.architecture with
1471 | Some UnknownArch | None -> system_architecture
1472 | Some arch -> arch in
1474 match state.memory with
1475 | Some 0 | None -> system_memory
1476 | Some memory -> memory in
1478 match state.vcpus with
1479 | Some 0 | None -> system_nr_cpus
1482 match state.mac_address with
1483 | Some "" | None -> random_mac_address ()
1484 | Some mac -> mac in
1487 (* Shortcut to make "<name>value</name>". *)
1488 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1489 (* ... and the _other_ sort of leaf (god I hate XML). *)
1490 let tleaf name attribs = Xml.Element (name, attribs, []) in
1492 (* Standard stuff for every domain. *)
1493 let name = leaf "name" hostname in
1494 let uuid = leaf "uuid" (random_uuid ()) in
1495 let maxmem = leaf "maxmem" (string_of_int (memory * 1024)) in
1496 let memory = leaf "memory" (string_of_int (memory * 1024)) in
1497 let vcpu = leaf "vcpu" (string_of_int vcpus) in
1499 (* Top-level stuff which differs for each HV type (isn't this supposed
1500 * to be portable ...)
1503 match state.hypervisor with
1505 [Xml.Element ("os", [],
1507 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1508 tleaf "boot" ["dev", "hd"]]);
1509 Xml.Element ("features", [],
1513 tleaf "clock" ["sync", "localtime"]]
1515 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1516 tleaf "clock" ["sync", "localtime"]]
1518 [Xml.Element ("os", [],
1519 [Xml.Element ("type",
1521 string_of_architecture architecture;
1523 [Xml.PCData "hvm"]);
1524 tleaf "boot" ["dev", "hd"]])]
1528 (* <devices> section. *)
1531 match state.hypervisor with
1533 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1535 [leaf "emulator" "/usr/bin/qemu"]
1537 [leaf "emulator" "/usr/bin/qemu-kvm"]
1541 Xml.Element ("interface", ["type", "user"],
1542 [tleaf "mac" ["address", mac_address]]) in
1543 (* XXX should have an option for Xen bridging:
1545 "interface", ["type","bridge"],
1546 [tleaf "source" ["bridge","xenbr0"];
1547 tleaf "mac" ["address",mac_address];
1548 tleaf "script" ["path","vif-bridge"]])*)
1549 let graphics = tleaf "graphics" ["type", "vnc"] in
1551 let disks = List.map (
1552 fun (_, _, remote_dev, remote_name) ->
1554 "disk", ["type", "file";
1556 [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1557 tleaf "target" ["dev", remote_dev]]
1559 ) devices_to_send in
1563 emulator @ interface :: graphics :: disks
1566 (* Put it all together in <domain type='foo'>. *)
1569 (match state.hypervisor with
1570 | Some Xen -> ["type", "xen"]
1571 | Some QEMU -> ["type", "qemu"]
1572 | Some KVM -> ["type", "kvm"]
1574 name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
1577 (* Convert XML configuration file to a string, then send it to the
1581 let xml = Xml.to_string_fmt xml in
1584 match state.hypervisor with
1585 | Some Xen | None -> ""
1586 | Some QEMU | Some KVM -> " -c qemu:///system" in
1587 let xml = sprintf "\
1589 This is a libvirt configuration file.
1591 To start the domain, do:
1594 -->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in
1596 let xml_len = String.length xml in
1597 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1599 let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1600 (* In OCaml this actually loops calling write(2) *)
1601 ignore (write sock xml 0 xml_len);
1602 do_disconnect conn in
1604 (* Send the device snapshots to the remote host. *)
1605 (* XXX This code should be made more robust against both network
1606 * errors and local I/O errors. Also should allow the user several
1607 * attempts to connect, or let them go back to the dialog stage.
1610 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1611 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1614 try List.assoc origin_dev all_block_devices
1615 with Not_found -> assert false (* internal error *) in
1617 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1618 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1620 (* Open the snapshot device. *)
1621 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1624 let (sock,_) as conn = do_connect remote_name size in
1626 (* Copy the data. *)
1627 let spinners = "|/-\\" (* "Oo" *) in
1628 let bufsize = 1024 * 1024 in
1629 let buffer = String.create bufsize in
1630 let start = gettimeofday () in
1632 let rec copy bytes_sent last_printed_at spinner =
1633 let n = read fd buffer 0 bufsize in
1635 let n' = write sock buffer 0 n in
1636 if n <> n' then assert false; (* never, according to the manual *)
1638 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1639 let last_printed_at, spinner =
1640 let now = gettimeofday () in
1641 (* Print progress every few seconds. *)
1642 if now -. last_printed_at > 2. then (
1643 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1644 let secs_elapsed = now -. start in
1645 printf "%.0f%% %c %.1f Mbps"
1646 (100. *. elapsed) spinners.[spinner]
1647 (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
1648 (* After 60 seconds has elapsed, start printing estimates. *)
1649 if secs_elapsed >= 60. then (
1650 let remaining = 1. -. elapsed in
1651 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1652 if secs_remaining > 120. then
1653 printf " (about %.0f minutes remaining)" (secs_remaining/.60.)
1655 printf " (about %.0f seconds remaining)"
1659 let spinner = (spinner + 1) mod String.length spinners in
1662 else last_printed_at, spinner in
1664 copy bytes_sent last_printed_at spinner
1668 printf "\n\n%!"; (* because of the messages printed above *)
1674 (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
1676 (* Clean up and reboot. *)
1678 msgbox (sprintf "%s completed" program_name)
1679 (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."
1680 remote_directory conf_filename)
1689 (*----------------------------------------------------------------------*)
1692 eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
1695 (* Make sure that exceptions from 'main' get printed out on stdout
1696 * as well as stderr, since stderr is probably redirected to the
1697 * logfile, and so not visible to the user.
1699 let handle_exn f arg =
1702 print_endline (Printexc.to_string exn);
1705 (* Test harness for the Makefile. The Makefile invokes this script as
1706 * 'virt-p2v --test' just to check it compiles. When it is running
1707 * from the actual live CD, there is a single parameter which is the
1708 * tty name (so usually 'virt-p2v tty1').
1711 match Array.to_list Sys.argv with
1712 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1713 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1714 | [ _; ttyname ] -> (* Run main with ttyname. *)
1715 handle_exn main (Some ttyname)
1716 | [ _ ] -> (* Interactive - no ttyname. *)
1717 handle_exn main None
1720 (* This file must end with a newline *)