1 #!/usr/bin/ocamlrun /usr/bin/ocaml
3 (* virt-p2v is a script which performs a physical to
4 * virtual conversion of local disks.
6 * Copyright (C) 2007-2008 Red Hat Inc.
7 * Written by Richard W.M. Jones <rjones@redhat.com>
9 * This program is free software; you can redistribute it and/or modify
10 * it under the terms of the GNU General Public License as published by
11 * the Free Software Foundation; either version 2 of the License, or
12 * (at your option) any later version.
14 * This program is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
19 * You should have received a copy of the GNU General Public License
20 * along with this program; if not, write to the Free Software
21 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
25 | Part of string * string (* eg. "hda", "1" *)
26 | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
28 | P2V (* physical to virtual *)
29 | V2V (* virtual to virtual *)
30 (*| V2P*) (* virtual to physical - not impl *)
32 | Auto of partition (* Automatic network configuration. *)
33 | Shell (* Start a shell. *)
34 | QEMUUserNet (* Assume we're running under qemu. *)
35 | Static of string * string * string * string * string
36 (* interface, address, netmask, gateway, nameserver *)
39 ssh_host : string; (* Remote host for SSH. *)
40 ssh_port : int; (* Remote port. *)
41 ssh_directory : string; (* Remote directory. *)
42 ssh_username : string; (* Remote username. *)
43 ssh_password : string; (* Remote password/passphrase. *)
44 ssh_compression : bool; (* If true, use SSH compression. *)
45 ssh_check : bool; (* If true, check SSH is working. *)
46 ssh_libvirtd : bool; (* If true, contact remote libvirtd. *)
53 | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
57 (*----------------------------------------------------------------------*)
58 (* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section.
60 * If left as they are, then this will create a generic virt-p2v script
61 * which asks the user for each question. If you set the defaults here
62 * then you will get a custom virt-p2v which is partially or even fully
63 * automated and won't ask the user any questions.
65 * Note that 'None' means 'no default' (ie. ask the user) whereas
66 * 'Some foo' means use 'foo' as the answer.
68 * These are documented in the virt-p2v(1) manual page.
70 * After changing them, run './virt-p2v --test' to check syntax.
73 (* If greeting is true, wait for keypress after boot and during
74 * final verification. Set to 'false' for less interactions.
76 let config_greeting = ref true
78 (* General type of transfer. *)
79 let config_transfer_type = ref None
81 (* Network configuration. *)
82 let config_network = ref None
84 (* SSH configuration. *)
85 let config_ssh = ref None
87 (* What to transfer. *)
88 let config_devices_to_send = ref None
89 let config_root_filesystem = ref None
91 (* Configuration of the target. *)
92 let config_hypervisor = ref None
93 let config_architecture = ref None
94 let config_memory = ref None
95 let config_vcpus = ref None
96 let config_mac_address = ref None
98 (* The name of the program as displayed in various places. *)
99 let program_name = "virt-p2v"
101 (* If you want to test the dialog stages, set this to true. *)
102 let test_dialog_stages = true
104 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
105 (*----------------------------------------------------------------------*)
107 (* Load external libraries. *)
110 #directory "+extlib";;
116 #directory "+xml-light";;
117 #load "xml-light.cma";;
124 (*----------------------------------------------------------------------*)
125 (* General helper functions. *)
127 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
128 let xs = List.sort ~cmp xs in
129 let rec loop = function
130 | [] -> [] | [x] -> [x]
131 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
132 | x :: xs -> x :: loop xs
136 let input_all_lines chan =
137 let lines = ref [] in
139 while true do lines := input_line chan :: !lines done; []
141 End_of_file -> List.rev !lines
143 let dev_of_partition = function
144 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
145 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
147 let string_of_architecture = function
154 | SPARC64 -> "sparc64"
155 | OtherArch arch -> arch
158 type nature = LinuxSwap
159 | LinuxRoot of architecture * linux_distro
160 | WindowsRoot (* Windows C: *)
161 | LinuxBoot (* Linux /boot *)
162 | NotRoot (* mountable, but not / or /boot *)
164 and linux_distro = RHEL of int * int
166 | Debian of int * int
169 let rec string_of_nature = function
170 | LinuxSwap -> "Linux swap"
171 | LinuxRoot (architecture, distro) ->
172 string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
173 | WindowsRoot -> "Windows root"
174 | LinuxBoot -> "Linux /boot"
175 | NotRoot -> "Mountable non-root"
176 | UnknownNature -> "Unknown"
177 and string_of_linux_distro = function
178 | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
179 | Fedora v -> sprintf "Fedora %d" v
180 | Debian (a,b) -> sprintf "Debian %d.%d" a b
181 | OtherLinux -> "Linux"
183 type ('a, 'b) either = Either of 'a | Or of 'b
185 (* We go into and out of newt mode at various stages, but we might
186 * also need to put up a message at any time. This keeps track of
187 * whether we are in newt mode or not.
189 * General tip: Try to do any complex operations like setting up the
190 * network or probing disks outside newt mode, and try not to throw
191 * exceptions in newt mode.
193 let in_newt = ref false
195 if !in_newt then f ()
199 try Either (Newt.init_and_finish f)
200 with exn -> Or exn in
202 match r with Either r -> r | Or exn -> raise exn
205 (* Clear the screen, open a new centered window, make sure the background
206 * and help messages are consistent.
208 let open_centered_window ?stage width height title =
209 if not !in_newt then failwith "open_centered_window: not in newt mode";
211 Newt.centered_window width height title;
213 program_name ^ (match stage with
215 | Some stage -> " - " ^ stage) in
216 Newt.draw_root_text 0 0 root_text;
217 Newt.push_help_line "F12 for next screen | [ALT] [F2] root / no password for shell"
219 (* Some general dialog boxes. *)
220 let message_box title text =
223 open_centered_window 40 20 title;
225 let textbox = Newt.textbox 1 1 36 14 [Newt.WRAP; Newt.SCROLL] in
226 Newt.textbox_set_text textbox text;
227 let ok = Newt.button 28 16 " OK " in
228 let form = Newt.form None None [] in
229 Newt.form_add_component form textbox;
230 Newt.form_add_component form ok;
232 Newt.component_takes_focus ok true;
234 ignore (Newt.run_form form);
238 (* Fail and exit with error. *)
241 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
242 message_box "Error" text;
245 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
246 let quote = Filename.quote
248 (* Run a shell command and check it returns 0. *)
250 eprintf "sh: %s\n%!" cmd;
251 if Sys.command cmd <> 0 then failwith (sprintf "Command failed:\n\n%s" cmd)
254 eprintf "shfailok: %s\n%!" cmd;
255 ignore (Sys.command cmd)
257 let shwithstatus cmd =
258 eprintf "shwithstatus: %s\n%!" cmd;
261 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
263 eprintf "shget: %s\n%!" cmd;
264 let chan = open_process_in cmd in
265 let lines = input_all_lines chan in
266 match close_process_in chan with
267 | WEXITED 0 -> Some lines (* command succeeded *)
268 | WEXITED _ -> None (* command failed *)
269 | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
270 | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
272 (* Start an interactive shell. Need to juggle file descriptors a bit
273 * because bash write PS1 to stderr (currently directed to the logfile).
277 | 0 -> (* child, runs bash *)
280 (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
282 Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
284 | _ -> (* parent, waits *)
285 eprintf "waiting for subshell to exit\n%!";
288 (* Some true if is dir/file, Some false if not, None if not found. *)
290 try Some ((stat path).st_kind = S_DIR)
291 with Unix_error (ENOENT, "stat", _) -> None
293 try Some ((stat path).st_kind = S_REG)
294 with Unix_error (ENOENT, "stat", _) -> None
296 (*----------------------------------------------------------------------*)
297 (* P2V-specific helper functions. *)
299 (* Generate a predictable safe name containing only letters, numbers
300 * and underscores. If passed a string with no letters or numbers,
301 * generates "_1", "_2", etc.
306 fun () -> incr i; "_" ^ string_of_int !i
309 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
310 let name = String.copy name in
311 let have_safe = ref false in
312 for i = 0 to String.length name - 1 do
313 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
315 if !have_safe then name else next_anon ()
317 type block_device = string * int64 (* "hda" & size in bytes *)
319 (* Parse the output of 'lvs' to get list of LV names, sizes,
320 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
323 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
327 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
331 let lines = List.map Pcre.split lines in
334 | [vg; lv; pvs; lvsize]
335 | [_; vg; lv; pvs; lvsize] ->
336 let pvs = String.nsplit pvs "," in
337 let pvs = List.filter_map (
340 let subs = Pcre.exec ~rex:devname pv in
341 Some (Pcre.get_substring subs 1)
344 eprintf "lvs: unexpected device name: %s\n%!" pv;
347 LV (vg, lv), pvs, lvsize
349 failwith ("lvs: unexpected output: " ^ String.concat "," line)
352 (* Get the partitions on a block device.
353 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
355 let get_partitions dev =
356 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
357 let devdir = "/sys/block/" ^ dev in
358 let parts = Sys.readdir devdir in
359 let parts = Array.to_list parts in
360 let parts = List.filter (
361 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
363 let parts = List.filter_map (
366 let subs = Pcre.exec ~rex part in
367 Some (Part (dev, Pcre.get_substring subs 1))
373 (* Generate snapshot device name from device name. *)
374 let snapshot_name dev =
375 "snap" ^ (safe_name dev)
377 (* Perform a device-mapper snapshot with ramdisk overlay. *)
379 let next_free_ram_disk =
381 fun () -> incr i; "/dev/ram" ^ string_of_int !i
383 fun origin_dev snapshot_dev ->
384 let ramdisk = next_free_ram_disk () in
386 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
387 let lines = shget cmd in
389 | Some (sectors::_) -> Int64.of_string sectors
391 failwith (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
393 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
394 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
395 snapshot_dev sectors origin_dev);
396 (* Create the snapshot. *)
397 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
398 snapshot_dev sectors snapshot_dev ramdisk)
400 (* Try to perform automatic network configuration, assuming a Fedora or
401 * RHEL-like root filesystem mounted on /mnt/root.
403 let auto_network () =
404 (* Fedora gives an error if this file doesn't exist. *)
405 sh "touch /etc/resolv.conf";
407 (* NB. Lazy unmount is required because dhclient keeps its current
408 * directory open on /etc/sysconfig/network-scripts/
410 sh "mount -o bind /mnt/root/etc /etc";
411 let status = shwithstatus "/etc/init.d/network start" in
414 (* Try to ping the default gateway to see if this worked. *)
415 shfailok "ping -c3 `/sbin/ip route list match 0.0.0.0 | head -1 | awk '{print $3}'`";
417 if !config_greeting then (
418 printf "\n\nDid automatic network configuration work?\n";
419 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
421 let line = read_line () in
422 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
425 (* Non-interactive: return the status of /etc/init.d/network start. *)
428 (* Configure the network statically. *)
429 let static_network (interface, address, netmask, gateway, nameserver) =
430 let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
432 do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
433 (quote interface) (quote address) (quote netmask));
434 do_cmd_or_exit (sprintf "route add default gw %s %s"
435 (quote gateway) (quote interface));
436 if nameserver <> "" then
437 do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
441 Exit -> false (* failed *)
443 (* http://fabrice.bellard.free.fr/qemu/qemu-doc.html#SEC30 *)
444 let qemu_network () =
445 sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0";
446 sh "route add default gw 10.0.2.2 eth0";
447 sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"
449 (* Map local device names to remote devices names. At the moment we
450 * just change sd* to hd* (as device names appear under fullvirt). In
451 * future, lots of complex possibilities.
453 let remote_of_origin_dev =
454 let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
455 let devsd_subst = Pcre.subst "hd$1" in
457 Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
459 (* Make an SSH connection to the remote machine. *)
461 let ssh_connect config =
462 let cmd = sprintf "ssh%s -l %s -p %s %s" XXXXX
463 (if config.ssh_compression then " -C" else "")
464 (quote config.ssh_username)
465 (quote config.ssh_port)
466 (quote config.ssh_host) in
467 eprintf "ssh_connect: %s\n%!" cmd;
468 let chan = open_process_out cmd in
469 descr_of_out_channel chan, chan
471 let ssh_disconnect (_, chan) =
472 match close_process_out chan with
473 | WEXITED 0 -> () (* OK *)
474 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
475 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
476 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)*)
478 (* Rewrite /mnt/root/etc/fstab. *)
479 let rewrite_fstab state devices_to_send =
480 let filename = "/mnt/root/etc/fstab" in
481 if is_file filename = Some true then (
482 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
484 let chan = open_in filename in
485 let lines = input_all_lines chan in
487 let lines = List.map Pcre.split lines in
488 let lines = List.map (
490 | dev :: rest when String.starts_with dev "/dev/" ->
491 let dev = String.sub dev 5 (String.length dev - 5) in
492 let dev = remote_of_origin_dev dev in
493 let dev = "/dev/" ^ dev in
498 let chan = open_out filename in
501 | [dev; mountpoint; fstype; options; freq; passno] ->
502 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
503 dev mountpoint fstype options freq passno
505 output_string chan (String.concat " " line);
506 output_char chan '\n'
511 (* Generate a random MAC address in the Xen-reserved space. *)
512 let random_mac_address () =
514 List.map (sprintf "%02x") (
515 List.map (fun _ -> Random.int 256) [0;0;0]
517 String.concat ":" ("00"::"16"::"3e"::random)
519 (* Generate a random UUID. *)
521 let hex = "0123456789abcdef" in
523 let str = String.create 32 in
524 for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
527 (*----------------------------------------------------------------------*)
528 (* Main entry point. *)
530 (* The general plan for the main function is to operate in stages:
535 * Information gathering about the system
536 * | (eg. block devices, number of CPUs, etc.)
538 * Greeting and type of transfer question
542 * | (after this point we have a working network)
545 * | (after this point we have a working SSH connection)
547 * Questions about what to transfer (block devs, root fs) <--.
550 * Questions about hypervisor configuration |
553 * Verify information -------- user wants to change info ----/
558 * Prior versions of virt-p2v (the ones which used 'dialog') had support
559 * for a back button so they could go back through dialogs. I removed
560 * this because it was hard to support and not particularly useful.
563 let rec main ttyname =
566 (* Running from an init script. We don't have much of a
567 * login environment, so set one up.
571 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
572 "/usr/bin"; "/bin"]);
573 putenv "HOME" "/root";
574 putenv "LOGNAME" "root";
576 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
579 (* Set up logging to /tmp/virt-p2v.log. *)
580 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
584 (* Log the start up time. *)
585 eprintf "\n\n**************************************************\n\n";
586 let tm = localtime (time ()) in
587 eprintf "%s starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
589 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
591 (* Connect stdin/stdout to the tty. *)
595 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
599 printf "%s starting up ...\n%!" program_name;
601 (* Disable screen blanking on tty. *)
602 sh "setterm -blank 0";
604 (* Check that the environment is a sane-looking live CD. If not, bail. *)
605 if not test_dialog_stages && is_dir "/mnt/root" <> Some true then
607 "You should only run this script from the live CD or a USB key.";
609 (* Start of the information gathering phase. *)
610 printf "Detecting hard drives (this may take some time) ...\n%!";
612 (* Search for all non-removable block devices. Do this early and bail
613 * if we can't find anything. This is a list of strings, like "hda".
615 let all_block_devices : block_device list =
616 let rex = Pcre.regexp "^[hs]d" in
617 let devices = Array.to_list (Sys.readdir "/sys/block") in
618 let devices = List.sort devices in
619 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
620 eprintf "all_block_devices: block devices: %s\n%!"
621 (String.concat "; " devices);
622 (* Run blockdev --getsize64 on each, and reject any where this fails
623 * (probably removable devices).
625 let devices = List.filter_map (
627 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
628 let lines = shget cmd in
630 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
631 | Some [] | None -> None
633 eprintf "all_block_devices: non-removable block devices: %s\n%!"
635 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
637 failwith "No non-removable block devices (hard disks, etc.) could be found on this machine.";
640 (* Search for partitions and LVs (anything that could contain a
641 * filesystem directly). We refer to these generically as
644 let all_partitions : partition list =
647 let lvs = get_lvs () in
648 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
649 let pvs = List.concat pvs in
650 let pvs = sort_uniq pvs in
651 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
652 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
653 eprintf "all_partitions: LVs: %s\n%!"
654 (String.concat "; " (List.map dev_of_partition lvs));
657 (* Partitions (eg. "sda1", "sda2"). *)
659 let parts = List.map fst all_block_devices in
660 let parts = List.map get_partitions parts in
661 let parts = List.concat parts in
662 eprintf "all_partitions: all partitions: %s\n%!"
663 (String.concat "; " (List.map dev_of_partition parts));
665 (* Remove any partitions which are PVs. *)
666 let parts = List.filter (
668 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
669 | LV _ -> assert false
672 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
673 (String.concat "; " (List.map dev_of_partition parts));
675 (* Concatenate LVs & Parts *)
678 (* Try to determine the nature of each partition.
679 * Root? Swap? Architecture? etc.
681 let all_partitions : (partition * nature) list =
682 (* Output of 'file' command for Linux swap file. *)
683 let swap = Pcre.regexp "Linux.*swap.*file" in
684 (* Contents of /etc/redhat-release. *)
685 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
686 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
687 (* Contents of /etc/debian_version. *)
688 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
689 (* Output of 'file' on certain executables. *)
690 let i386 = Pcre.regexp ", Intel 80386," in
691 let x86_64 = Pcre.regexp ", x86-64," in
692 let itanic = Pcre.regexp ", IA-64," in
694 (* Examine the filesystem mounted on 'mnt' to determine the
695 * operating system, and, if Linux, the distro.
698 if is_dir (mnt ^ "/Windows") = Some true &&
699 is_file (mnt ^ "/autoexec.bat") = Some true then
701 else if is_dir (mnt ^ "/etc") = Some true &&
702 is_dir (mnt ^ "/sbin") = Some true &&
703 is_dir (mnt ^ "/var") = Some true then (
704 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
705 let chan = open_in (mnt ^ "/etc/redhat-release") in
706 let lines = input_all_lines chan in
710 | [] -> (* empty /etc/redhat-release ...? *)
711 LinuxRoot (UnknownArch, OtherLinux)
712 | line::_ -> (* try to detect OS from /etc/redhat-release *)
714 let subs = Pcre.exec ~rex:rhel line in
715 let major = int_of_string (Pcre.get_substring subs 1) in
717 try int_of_string (Pcre.get_substring subs 2)
718 with Not_found -> 0 in
719 LinuxRoot (UnknownArch, RHEL (major, minor))
721 Not_found | Failure "int_of_string" ->
723 let subs = Pcre.exec ~rex:fedora line in
724 let version = int_of_string (Pcre.get_substring subs 1) in
725 LinuxRoot (UnknownArch, Fedora version)
727 Not_found | Failure "int_of_string" ->
728 LinuxRoot (UnknownArch, OtherLinux)
730 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
731 let chan = open_in (mnt ^ "/etc/debian_version") in
732 let lines = input_all_lines chan in
736 | [] -> (* empty /etc/debian_version ...? *)
737 LinuxRoot (UnknownArch, OtherLinux)
738 | line::_ -> (* try to detect version from /etc/debian_version *)
740 let subs = Pcre.exec ~rex:debian line in
741 let major = int_of_string (Pcre.get_substring subs 1) in
742 let minor = int_of_string (Pcre.get_substring subs 2) in
743 LinuxRoot (UnknownArch, Debian (major, minor))
745 Not_found | Failure "int_of_string" ->
746 LinuxRoot (UnknownArch, OtherLinux)
749 LinuxRoot (UnknownArch, OtherLinux)
750 ) else if is_dir (mnt ^ "/grub") = Some true &&
751 is_file (mnt ^ "/grub/stage1") = Some true then (
754 NotRoot (* mountable, but not a root filesystem *)
757 (* Examine the Linux root filesystem mounted on 'mnt' to
758 * determine the architecture. We do this by looking at some
759 * well-known binaries that we expect to be there.
761 let detect_architecture mnt =
762 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
764 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
765 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
766 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
772 let dev = dev_of_partition part in (* Get /dev device. *)
775 (* Use 'file' command to detect if it is swap. *)
776 let cmd = "file -sbL " ^ quote dev in
778 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
780 (* Blindly try to mount the device. *)
781 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
782 match shwithstatus cmd with
784 let os = detect_os "/mnt/root" in
787 | LinuxRoot (UnknownArch, distro) ->
788 let architecture = detect_architecture "/mnt/root" in
789 LinuxRoot (architecture, distro)
791 sh "umount /mnt/root";
794 | _ -> UnknownNature (* not mountable *)
798 eprintf "partition detection: %s is %s\n%!"
799 dev (string_of_nature nature);
805 printf "Finished detecting hard drives.\n%!";
807 (* Autodetect system memory. *)
809 let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
811 | Some (mem::_) -> int_of_float (float_of_string mem)
814 (* Autodetect system # pCPUs. *)
817 shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
819 | Some (cpus::_) -> int_of_string cpus
822 (* Greeting, type of transfer, network question stages.
823 * These are all done in newt mode.
825 let config_transfer_type, config_network =
829 if !config_greeting then
830 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);
832 (* Type of transfer. *)
833 let config_transfer_type =
834 match !config_transfer_type with
837 open_centered_window ~stage:"Transfer type"
838 40 10 "Transfer type";
841 Newt.radio_button 1 1 "Physical to virtual (P2V)" true
844 Newt.radio_button 1 2 "Virtual to virtual (V2V)" false
846 let ok = Newt.button 28 6 " OK " in
848 let form = Newt.form None None [] in
849 Newt.form_add_components form [p2v; v2v];
850 Newt.form_add_component form ok;
854 ignore (Newt.run_form form);
856 let r = Newt.radio_get_current p2v in
857 if Newt.component_equals r p2v then P2V
858 else if Newt.component_equals r v2v then V2V
867 (* Network configuration. *)
869 match !config_network with
872 open_centered_window ~stage:"Network"
873 60 20 "Configure network";
875 let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in
876 Newt.listbox_set_width autolist 52;
878 (* Populate the "Automatic" listbox with RHEL/Fedora
879 * root partitions found which allow us to do
880 * automatic configuration in a known way.
882 let partition_map = Hashtbl.create 13 in
883 let maplen = ref 1 in
884 let rec loop = function
886 | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
890 (dev_of_partition partition)
891 (string_of_linux_distro distro) in
892 Hashtbl.add partition_map (!maplen) partition;
894 Newt.listbox_append_entry autolist label (!maplen)
898 | _ :: parts -> loop parts
902 (* If there is no suitable root partition (the listbox
903 * is empty) then disable the auto option and the listbox.
905 let no_auto = Hashtbl.length partition_map = 0 in
908 Newt.radio_button 1 1
909 "Automatic from:" (not no_auto) None in
911 Newt.radio_button 1 6
912 "Start a shell" no_auto (Some auto) in
915 Newt.component_takes_focus auto false;
916 Newt.component_takes_focus autolist false
920 Newt.radio_button 1 7
921 "QEMU user network" false (Some shell) in
923 Newt.radio_button 1 8
924 "No network or network already configured" false
927 Newt.radio_button 1 9
928 "Static configuration:" false (Some nonet) in
930 let label1 = Newt.label 4 10 "Interface" in
931 let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
932 let label2 = Newt.label 4 11 "Address" in
933 let entry2 = Newt.entry 16 11 None 16 [] in
934 let label3 = Newt.label 4 12 "Netmask" in
935 let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
936 let label4 = Newt.label 4 13 "Gateway" in
937 let entry4 = Newt.entry 16 13 None 16 [] in
938 let label5 = Newt.label 4 14 "Nameserver" in
939 let entry5 = Newt.entry 16 14 None 16 [] in
941 let enable_static () =
942 Newt.component_takes_focus entry1 true;
943 Newt.component_takes_focus entry2 true;
944 Newt.component_takes_focus entry3 true;
945 Newt.component_takes_focus entry4 true;
946 Newt.component_takes_focus entry5 true
949 let disable_static () =
950 Newt.component_takes_focus entry1 false;
951 Newt.component_takes_focus entry2 false;
952 Newt.component_takes_focus entry3 false;
953 Newt.component_takes_focus entry4 false;
954 Newt.component_takes_focus entry5 false
957 let enable_autolist () =
958 Newt.component_takes_focus autolist true
960 let disable_autolist () =
961 Newt.component_takes_focus autolist false
965 Newt.component_add_callback auto
966 (fun () ->disable_static (); enable_autolist ());
967 Newt.component_add_callback shell
968 (fun () -> disable_static (); disable_autolist ());
969 Newt.component_add_callback qemu
970 (fun () -> disable_static (); disable_autolist ());
971 Newt.component_add_callback nonet
972 (fun () -> disable_static (); disable_autolist ());
973 Newt.component_add_callback static
974 (fun () -> enable_static (); disable_autolist ());
976 let ok = Newt.button 48 16 " OK " in
978 let form = Newt.form None None [] in
979 Newt.form_add_component form auto;
980 Newt.form_add_component form autolist;
981 Newt.form_add_components form [shell;qemu;nonet;static];
982 Newt.form_add_components form
983 [label1;label2;label3;label4;label5];
984 Newt.form_add_components form
985 [entry1;entry2;entry3;entry4;entry5];
986 Newt.form_add_component form ok;
990 ignore (Newt.run_form form);
992 let r = Newt.radio_get_current auto in
993 if Newt.component_equals r auto then (
994 match Newt.listbox_get_current autolist with
996 | Some i -> Auto (Hashtbl.find partition_map i)
998 else if Newt.component_equals r shell then Shell
999 else if Newt.component_equals r qemu then QEMUUserNet
1000 else if Newt.component_equals r nonet then NoNetwork
1001 else if Newt.component_equals r static then (
1002 let interface = Newt.entry_get_value entry1 in
1003 let address = Newt.entry_get_value entry2 in
1004 let netmask = Newt.entry_get_value entry3 in
1005 let gateway = Newt.entry_get_value entry4 in
1006 let nameserver = Newt.entry_get_value entry5 in
1007 if interface = "" || address = "" ||
1008 netmask = "" || gateway = "" then
1011 Static (interface, address, netmask, gateway, nameserver)
1020 config_transfer_type, config_network
1023 (* Try to bring up the network. *)
1024 (match config_network with
1026 printf "Network configuration.\n\n";
1027 printf "Please configure the network from this shell.\n\n";
1028 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1031 | Static (interface, address, netmask, gateway, nameserver) ->
1032 printf "Trying static network configuration.\n\n%!";
1033 if not (static_network
1034 (interface, address, netmask, gateway, nameserver)) then (
1035 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1036 printf "Please configure the network from this shell.\n\n";
1037 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1043 "Trying network auto-configuration from root filesystem ...\n\n%!";
1045 (* Mount the root filesystem read-only under /mnt/root. *)
1046 sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");
1048 if not (auto_network ()) then (
1049 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1050 printf "Please configure the network from this shell.\n\n";
1051 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1055 (* NB. Lazy unmount is required because dhclient keeps its current
1056 * directory open on /etc/sysconfig/network-scripts/
1058 sh ("umount -l /mnt/root");
1061 printf "Trying QEMU network configuration.\n\n%!";
1064 | NoNetwork -> (* this is easy ... *) ()
1067 (* SSH configuration phase. *)
1071 match !config_ssh with
1074 (* Query the user for SSH configuration. *)
1075 open_centered_window ~stage:"SSH configuration"
1076 60 20 "SSH configuration";
1078 let label1 = Newt.label 1 1 "Remote host" in
1079 let host = Newt.entry 20 1 None 36 [] in
1080 let label2 = Newt.label 1 2 "Remote port" in
1081 let port = Newt.entry 20 2 (Some "22") 6 [] in
1082 let label3 = Newt.label 1 3 "Remote directory" in
1083 let dir = Newt.entry 20 3 (Some "/var/lib/xen/images") 36 [] in
1084 let label4 = Newt.label 1 4 "SSH username" in
1085 let user = Newt.entry 20 4 (Some "root") 16 [] in
1086 let label5 = Newt.label 1 5 "SSH password" in
1087 let pass = Newt.entry 20 5 None 16 [Newt.PASSWORD] in
1090 Newt.checkbox 16 7 "Use SSH compression (not good for LANs)"
1093 let check = Newt.checkbox 16 9 "Test SSH connection" '*' None in
1095 Newt.checkbox 16 10 "libvirtd is running on host" '*' None in
1097 Newt.component_add_callback check
1099 if Newt.checkbox_get_value check = '*' then
1100 Newt.component_takes_focus libvirtd true
1102 Newt.component_takes_focus libvirtd false;
1103 Newt.checkbox_set_value libvirtd ' '
1107 let ok = Newt.button 48 16 " OK " in
1109 let form = Newt.form None None [] in
1110 Newt.form_add_components form [label1;label2;label3;label4;label5];
1111 Newt.form_add_components form [host;port;dir;user;pass];
1112 Newt.form_add_components form [compr;check;libvirtd];
1113 Newt.form_add_component form ok;
1117 ignore (Newt.run_form form);
1119 let host = Newt.entry_get_value host in
1120 let port = int_of_string (Newt.entry_get_value port) in
1121 let dir = Newt.entry_get_value dir in
1122 let user = Newt.entry_get_value user in
1123 let pass = Newt.entry_get_value pass in
1124 let compr = Newt.checkbox_get_value compr = '*' in
1125 let check = Newt.checkbox_get_value check = '*' in
1126 let libvirtd = Newt.checkbox_get_value libvirtd = '*' in
1127 if host <> "" && port > 0 && port < 65536 &&
1129 { ssh_host = host; ssh_port = port; ssh_directory = dir;
1130 ssh_username = user; ssh_password = pass;
1131 ssh_compression = compr;
1132 ssh_check = check; ssh_libvirtd = libvirtd }
1136 Failure "int_of_string" -> loop ()
1144 (* If asked, check the SSH connection. At the same time
1145 * grab the capabilities from the remote host.
1148 if config_ssh.ssh_check then (
1149 printf "Testing SSH connection.\n\n";
1159 let ask_devices state =
1160 let selected_devices = Option.default [] state.devices_to_send in
1161 let devices = List.map (
1162 fun (dev, blksize) ->
1164 sprintf "/dev/%s (%.3f GB)" dev
1165 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
1166 List.mem dev selected_devices)
1167 ) all_block_devices in
1169 checklist "Devices" "Pick devices to send" 15 50 8 devices
1171 | Yes [] | No | Help | Error -> Ask_again
1172 | Yes devices -> Next { state with devices_to_send = Some devices }
1176 let ask_root state =
1177 let parts = List.mapi (
1178 fun i (part, nature) ->
1181 | LinuxSwap -> " (Linux swap)"
1182 | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
1183 | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
1184 | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
1185 | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
1186 | WindowsRoot -> " (Windows C:)"
1187 | LinuxBoot -> " (Linux /boot)"
1188 | NotRoot -> " (filesystem)"
1189 | UnknownNature -> "" in
1191 dev_of_partition part ^ descr,
1192 Some part = state.root_filesystem)
1195 radiolist "Root device"
1196 "Pick partition containing the root (/) filesystem" 18 70 9
1200 let (part, _) = List.nth all_partitions (int_of_string i) in
1201 Next { state with root_filesystem = Some part }
1202 | Yes [] | No | Help | Error -> Ask_again
1206 let ask_hypervisor state =
1208 radiolist "Hypervisor"
1209 "Choose hypervisor / virtualization system"
1211 "xen", "Xen", state.hypervisor = Some Xen;
1212 "qemu", "QEMU", state.hypervisor = Some QEMU;
1213 "kvm", "KVM", state.hypervisor = Some KVM;
1214 "other", "Other", state.hypervisor = None
1217 | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
1218 | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
1219 | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
1220 | Yes _ -> Next { state with hypervisor = None }
1221 | No | Help | Error -> Ask_again
1225 let ask_architecture state =
1227 radiolist "Architecture" "Machine architecture" 16 50 8 [
1228 "i386", "i386 and up (32 bit)", state.architecture = Some I386;
1229 "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
1230 "ia64", "Itanium IA64", state.architecture = Some IA64;
1231 "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
1232 "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
1233 "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
1234 "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
1235 "auto", "Auto-detect",
1236 state.architecture = None || state.architecture = Some UnknownArch;
1239 | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
1240 | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
1241 | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
1242 | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
1243 | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
1244 | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
1245 | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
1246 | Yes _ -> Next { state with architecture = Some UnknownArch }
1247 | No | Help | Error -> Ask_again
1251 let ask_memory state =
1253 inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
1255 (Option.map_default string_of_int "" state.memory)
1257 | Yes (""::_ | []) -> Next { state with memory = Some 0 }
1259 let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
1260 if mem < 0 || (mem > 0 && mem < 64) then Ask_again
1261 else Next { state with memory = Some mem }
1262 | No | Help | Error -> Ask_again
1266 let ask_vcpus state =
1268 inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
1270 (Option.map_default string_of_int "" state.vcpus)
1272 | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
1275 try int_of_string vcpus with Failure "int_of_string" -> -1 in
1276 if vcpus < 0 then Ask_again
1277 else Next { state with vcpus = Some vcpus }
1278 | No | Help | Error -> Ask_again
1282 let ask_mac_address state =
1284 inputbox "MAC address"
1285 "Network MAC address. Leave blank to use a random address." 10 50
1286 (Option.default "" state.mac_address)
1288 | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
1289 | Yes (mac :: _) -> Next { state with mac_address = Some mac }
1290 | No | Help | Error -> Ask_again
1294 let ask_compression state =
1296 radiolist "Network compression" "Enable network compression" 10 50 2 [
1297 "yes", "Yes, compress network traffic", state.compression <> Some false;
1298 "no", "No, don't compress", state.compression = Some false
1301 | Yes ("no"::_) -> Next { state with compression = Some false }
1302 | Yes _ -> Next { state with compression = Some true }
1303 | No | Help | Error -> Ask_again
1307 let ask_verify state =
1309 yesno "Verify and proceed"
1310 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
1323 (Option.default "" state.remote_host)
1324 (Option.default "" state.remote_port)
1325 (Option.default "" state.remote_directory)
1326 (match state.network with
1327 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
1328 | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net"
1330 (String.concat "," (Option.default [] state.devices_to_send))
1331 (Option.map_default dev_of_partition "" state.root_filesystem)
1332 (match state.hypervisor with
1333 | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
1334 | None -> "Other / not set")
1335 (match state.architecture with
1336 | Some UnknownArch -> "Auto-detect"
1337 | Some arch -> string_of_architecture arch | None -> "")
1338 (match state.memory with
1339 | Some 0 -> "Same as physical"
1340 | Some mem -> string_of_int mem ^ " MB" | None -> "")
1341 (match state.vcpus with
1342 | Some 0 -> "Same as physical"
1343 | Some vcpus -> string_of_int vcpus | None -> "")
1344 (match state.mac_address with
1345 | Some "" -> "Random" | Some mac -> mac | None -> "")
1346 (Option.default true state.compression)
1350 | Yes _ -> Next state
1352 | No | Help | Error -> Ask_again
1355 (* This is the list of dialogs, in order. The user can go forwards or
1356 * backwards through them.
1358 * The second parameter in each tuple is true if we need to skip
1359 * this dialog statically (info already supplied in 'defaults' above).
1361 * The third parameter in each tuple is a function that tests whether
1362 * this dialog should be skipped, given other parts of the current state.
1365 let dont_skip _ = false in
1367 ask_greeting, not defaults.greeting, dont_skip;
1368 ask_hostname, defaults.remote_host <> None, dont_skip;
1369 ask_port, defaults.remote_port <> None, dont_skip;
1370 ask_directory, defaults.remote_directory <> None, dont_skip;
1371 ask_username, defaults.remote_username <> None, dont_skip;
1372 ask_network, defaults.network <> None, dont_skip;
1373 ask_static_network_config,
1374 defaults.static_network_config <> None,
1375 (function { network = Some Static } -> false | _ -> true);
1376 ask_devices, defaults.devices_to_send <> None, dont_skip;
1377 ask_root, defaults.root_filesystem <> None, dont_skip;
1378 ask_hypervisor, defaults.hypervisor <> None, dont_skip;
1379 ask_architecture, defaults.architecture <> None, dont_skip;
1380 ask_memory, defaults.memory <> None, dont_skip;
1381 ask_vcpus, defaults.vcpus <> None, dont_skip;
1382 ask_mac_address, defaults.mac_address <> None, dont_skip;
1383 ask_compression, defaults.compression <> None, dont_skip;
1384 ask_verify, not defaults.greeting, dont_skip;
1387 (* Loop through the dialogs until we reach the end. *)
1388 let rec loop ?(back=false) posn state =
1389 eprintf "dialog loop: posn = %d, back = %b\n%!" posn back;
1390 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
1391 else if posn < 0 then loop 0 state
1393 let dlg, skip_static, skip_dynamic = dlgs.(posn) in
1394 if skip_static || skip_dynamic state then
1395 (* Skip this dialog. *)
1396 loop ~back (if back then posn-1 else posn+1) state
1399 match dlg state with
1400 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
1401 | Ask_again -> loop posn state (* Repeat the question. *)
1402 | Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *)
1406 let state = loop 0 defaults in
1408 eprintf "finished dialog loop\n%!";
1410 (* In test mode, exit here before we do bad things to the developer's
1413 if test_dialog_stages then exit 1;
1415 (* Switch LVM config. *)
1417 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1418 sh "rm -f /etc/lvm/cache/.cache";
1419 sh "rm -f /etc/lvm.new/cache/.cache";
1421 (* Snapshot the block devices to send. *)
1422 let devices_to_send = Option.get state.devices_to_send in
1423 let devices_to_send =
1426 let snapshot_dev = snapshot_name origin_dev in
1427 snapshot origin_dev snapshot_dev;
1428 (origin_dev, snapshot_dev)
1429 ) devices_to_send in
1431 (* Run kpartx on the snapshots. *)
1433 fun (origin, snapshot) ->
1434 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1437 (* Rescan for LVs. *)
1441 (* Mount the root filesystem under /mnt/root. *)
1442 let root_filesystem = Option.get state.root_filesystem in
1443 (match root_filesystem with
1444 | Part (dev, partnum) ->
1445 let dev = dev ^ partnum in
1446 let snapshot_dev = snapshot_name dev in
1447 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1450 (* The LV will be backed by a snapshot device, so just mount
1453 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1456 (* Work out what devices will be called at the remote end. *)
1457 let devices_to_send = List.map (
1458 fun (origin_dev, snapshot_dev) ->
1459 let remote_dev = remote_of_origin_dev origin_dev in
1460 (origin_dev, snapshot_dev, remote_dev)
1461 ) devices_to_send in
1463 (* Modify files on the root filesystem. *)
1464 rewrite_fstab state devices_to_send;
1465 (* XXX Other files to rewrite? *)
1467 (* Unmount the root filesystem and sync disks. *)
1468 sh "umount /mnt/root";
1469 sh "sync"; (* Ugh, should be in stdlib. *)
1471 (* Get architecture of root filesystem, detected previously. *)
1472 let system_architecture =
1474 (match List.assoc root_filesystem all_partitions with
1475 | LinuxRoot (arch, _) -> arch
1476 | _ -> raise Not_found
1480 (* None was detected before, so assume same as live CD. *)
1481 let arch = shget "uname -m" in
1483 | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
1484 | Some ("x86_64"::_) -> X86_64
1485 | Some ("ia64"::_) -> IA64
1486 | _ -> I386 (* probably wrong XXX *) in
1488 let remote_host = Option.get state.remote_host in
1489 let remote_port = Option.get state.remote_port in
1490 let remote_directory = Option.get state.remote_directory in
1491 let remote_username = Option.get state.remote_username in
1493 (* XXX This is using the hostname derived from network configuration
1494 * above. We might want to ask the user to choose.
1496 let hostname = safe_name (gethostname ()) in
1498 let date = sprintf "%04d%02d%02d%02d%02d"
1499 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1500 "p2v-" ^ hostname ^ "-" ^ date in
1502 (* Work out what the image filenames will be at the remote end. *)
1503 let devices_to_send = List.map (
1504 fun (origin_dev, snapshot_dev, remote_dev) ->
1505 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1506 (origin_dev, snapshot_dev, remote_dev, remote_name)
1507 ) devices_to_send in
1509 (* Write a configuration file. Not sure if this is any better than
1510 * just 'sprintf-ing' bits of XML text together, but at least we will
1511 * always get well-formed XML.
1513 * XXX For some of the stuff here we really should do a
1514 * virConnectGetCapabilities call to the remote host first.
1516 * XXX There is a case for using virt-install to generate this XML.
1517 * When we start to incorporate libvirt access & storage API this
1518 * needs to be rethought.
1520 let conf_filename = basename ^ ".conf" in
1523 match state.architecture with
1524 | Some UnknownArch | None -> system_architecture
1525 | Some arch -> arch in
1527 match state.memory with
1528 | Some 0 | None -> system_memory
1529 | Some memory -> memory in
1531 match state.vcpus with
1532 | Some 0 | None -> system_nr_cpus
1535 match state.mac_address with
1536 | Some "" | None -> random_mac_address ()
1537 | Some mac -> mac in
1540 (* Shortcut to make "<name>value</name>". *)
1541 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1542 (* ... and the _other_ sort of leaf (god I hate XML). *)
1543 let tleaf name attribs = Xml.Element (name, attribs, []) in
1545 (* Standard stuff for every domain. *)
1546 let name = leaf "name" hostname in
1547 let uuid = leaf "uuid" (random_uuid ()) in
1548 let maxmem = leaf "maxmem" (string_of_int (memory * 1024)) in
1549 let memory = leaf "memory" (string_of_int (memory * 1024)) in
1550 let vcpu = leaf "vcpu" (string_of_int vcpus) in
1552 (* Top-level stuff which differs for each HV type (isn't this supposed
1553 * to be portable ...)
1556 match state.hypervisor with
1558 [Xml.Element ("os", [],
1560 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1561 tleaf "boot" ["dev", "hd"]]);
1562 Xml.Element ("features", [],
1566 tleaf "clock" ["sync", "localtime"]]
1568 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1569 tleaf "clock" ["sync", "localtime"]]
1571 [Xml.Element ("os", [],
1572 [Xml.Element ("type",
1574 string_of_architecture architecture;
1576 [Xml.PCData "hvm"]);
1577 tleaf "boot" ["dev", "hd"]])]
1581 (* <devices> section. *)
1584 match state.hypervisor with
1586 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1588 [leaf "emulator" "/usr/bin/qemu"]
1590 [leaf "emulator" "/usr/bin/qemu-kvm"]
1594 Xml.Element ("interface", ["type", "user"],
1595 [tleaf "mac" ["address", mac_address]]) in
1596 (* XXX should have an option for Xen bridging:
1598 "interface", ["type","bridge"],
1599 [tleaf "source" ["bridge","xenbr0"];
1600 tleaf "mac" ["address",mac_address];
1601 tleaf "script" ["path","vif-bridge"]])*)
1602 let graphics = tleaf "graphics" ["type", "vnc"] in
1604 let disks = List.map (
1605 fun (_, _, remote_dev, remote_name) ->
1607 "disk", ["type", "file";
1609 [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1610 tleaf "target" ["dev", remote_dev]]
1612 ) devices_to_send in
1616 emulator @ interface :: graphics :: disks
1619 (* Put it all together in <domain type='foo'>. *)
1622 (match state.hypervisor with
1623 | Some Xen -> ["type", "xen"]
1624 | Some QEMU -> ["type", "qemu"]
1625 | Some KVM -> ["type", "kvm"]
1627 name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
1630 (* Convert XML configuration file to a string, then send it to the
1634 let xml = Xml.to_string_fmt xml in
1637 match state.hypervisor with
1638 | Some Xen | None -> ""
1639 | Some QEMU | Some KVM -> " -c qemu:///system" in
1640 let xml = sprintf "\
1642 This is a libvirt configuration file.
1644 To start the domain, do:
1647 -->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in
1649 let xml_len = String.length xml in
1650 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1652 let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1653 (* In OCaml this actually loops calling write(2) *)
1654 ignore (write sock xml 0 xml_len);
1655 do_disconnect conn in
1657 (* Send the device snapshots to the remote host. *)
1658 (* XXX This code should be made more robust against both network
1659 * errors and local I/O errors. Also should allow the user several
1660 * attempts to connect, or let them go back to the dialog stage.
1663 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1664 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1667 try List.assoc origin_dev all_block_devices
1668 with Not_found -> assert false (* internal error *) in
1670 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1671 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1673 (* Open the snapshot device. *)
1674 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1677 let (sock,_) as conn = do_connect remote_name size in
1679 (* Copy the data. *)
1680 let spinners = "|/-\\" (* "Oo" *) in
1681 let bufsize = 1024 * 1024 in
1682 let buffer = String.create bufsize in
1683 let start = gettimeofday () in
1685 let rec copy bytes_sent last_printed_at spinner =
1686 let n = read fd buffer 0 bufsize in
1688 let n' = write sock buffer 0 n in
1689 if n <> n' then assert false; (* never, according to the manual *)
1691 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1692 let last_printed_at, spinner =
1693 let now = gettimeofday () in
1694 (* Print progress every few seconds. *)
1695 if now -. last_printed_at > 2. then (
1696 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1697 let secs_elapsed = now -. start in
1698 printf "%.0f%% %c %.1f Mbps"
1699 (100. *. elapsed) spinners.[spinner]
1700 (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
1701 (* After 60 seconds has elapsed, start printing estimates. *)
1702 if secs_elapsed >= 60. then (
1703 let remaining = 1. -. elapsed in
1704 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1705 if secs_remaining > 120. then
1706 printf " (about %.0f minutes remaining)" (secs_remaining/.60.)
1708 printf " (about %.0f seconds remaining)"
1712 let spinner = (spinner + 1) mod String.length spinners in
1715 else last_printed_at, spinner in
1717 copy bytes_sent last_printed_at spinner
1721 printf "\n\n%!"; (* because of the messages printed above *)
1727 (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
1729 (* Clean up and reboot. *)
1731 msgbox (sprintf "%s completed" program_name)
1732 (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."
1733 remote_directory conf_filename)
1742 (*----------------------------------------------------------------------*)
1745 eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
1748 (* Make sure that exceptions from 'main' get printed out on stdout
1749 * as well as stderr, since stderr is probably redirected to the
1750 * logfile, and so not visible to the user.
1752 let handle_exn f arg =
1755 print_endline (Printexc.to_string exn);
1758 (* Test harness for the Makefile. The Makefile invokes this script as
1759 * 'virt-p2v --test' just to check it compiles. When it is running
1760 * from the actual live CD, there is a single parameter which is the
1761 * tty name (so usually 'virt-p2v tty1').
1764 match Array.to_list Sys.argv with
1765 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1766 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1767 | [ _; ttyname ] -> (* Run main with ttyname. *)
1768 handle_exn main (Some ttyname)
1769 | [ _ ] -> (* Interactive - no ttyname. *)
1770 handle_exn main None
1773 (* This file must end with a newline *)