1 #!/usr/bin/ocamlrun /usr/bin/ocaml
3 (* virt-p2v is a script which performs a physical to
4 * virtual conversion of local disks.
6 * Copyright (C) 2007-2008 Red Hat Inc.
7 * Written by Richard W.M. Jones <rjones@redhat.com>
9 * This program is free software; you can redistribute it and/or modify
10 * it under the terms of the GNU General Public License as published by
11 * the Free Software Foundation; either version 2 of the License, or
12 * (at your option) any later version.
14 * This program is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
19 * You should have received a copy of the GNU General Public License
20 * along with this program; if not, write to the Free Software
21 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
25 | Part of string * string (* eg. "hda", "1" *)
26 | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
28 | P2V (* physical to virtual *)
29 | V2V (* virtual to virtual *)
30 (*| V2P*) (* virtual to physical - not impl *)
32 | Auto of partition (* Automatic network configuration. *)
33 | Shell (* Start a shell. *)
34 | QEMUUserNet (* Assume we're running under qemu. *)
35 | Static of string * string * string * string * string
36 (* interface, address, netmask, gateway, nameserver *)
39 ssh_host : string; (* Remote host for SSH. *)
40 ssh_port : string; (* Remote port. *)
41 ssh_directory : string; (* Remote directory. *)
42 ssh_username : string; (* Remote username. *)
43 ssh_compression : bool; (* If true, use SSH compression. *)
44 ssh_check : bool; (* If true, check SSH is working. *)
51 | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
55 (*----------------------------------------------------------------------*)
56 (* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section.
58 * If left as they are, then this will create a generic virt-p2v script
59 * which asks the user for each question. If you set the defaults here
60 * then you will get a custom virt-p2v which is partially or even fully
61 * automated and won't ask the user any questions.
63 * Note that 'None' means 'no default' (ie. ask the user) whereas
64 * 'Some foo' means use 'foo' as the answer.
66 * These are documented in the virt-p2v(1) manual page.
68 * After changing them, run './virt-p2v --test' to check syntax.
71 (* If greeting is true, wait for keypress after boot and during
72 * final verification. Set to 'false' for less interactions.
74 let config_greeting = ref true
76 (* General type of transfer. *)
77 let config_transfer_type = ref None
79 (* Network configuration. *)
80 let config_network = ref None
82 (* SSH configuration. *)
83 let config_ssh = ref None
85 (* What to transfer. *)
86 let config_devices_to_send = ref None
87 let config_root_filesystem = ref None
89 (* Configuration of the target. *)
90 let config_hypervisor = ref None
91 let config_architecture = ref None
92 let config_memory = ref None
93 let config_vcpus = ref None
94 let config_mac_address = ref None
95 let config_libvirtd = ref None
97 (* The name of the program as displayed in various places. *)
98 let program_name = "virt-p2v"
100 (* If you want to test the dialog stages, set this to true. *)
101 let test_dialog_stages = false
103 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
104 (*----------------------------------------------------------------------*)
106 (* Load external libraries. *)
109 #directory "+extlib";;
115 #directory "+xml-light";;
116 #load "xml-light.cma";;
123 (*----------------------------------------------------------------------*)
124 (* General helper functions. *)
126 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
127 let xs = List.sort ~cmp xs in
128 let rec loop = function
129 | [] -> [] | [x] -> [x]
130 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
131 | x :: xs -> x :: loop xs
135 let input_all_lines chan =
136 let lines = ref [] in
138 while true do lines := input_line chan :: !lines done; []
140 End_of_file -> List.rev !lines
142 let dev_of_partition = function
143 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
144 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
146 let string_of_architecture = function
153 | SPARC64 -> "sparc64"
154 | OtherArch arch -> arch
157 type nature = LinuxSwap
158 | LinuxRoot of architecture * linux_distro
159 | WindowsRoot (* Windows C: *)
160 | LinuxBoot (* Linux /boot *)
161 | NotRoot (* mountable, but not / or /boot *)
163 and linux_distro = RHEL of int * int
165 | Debian of int * int
168 let rec string_of_nature = function
169 | LinuxSwap -> "Linux swap"
170 | LinuxRoot (architecture, distro) ->
171 string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
172 | WindowsRoot -> "Windows root"
173 | LinuxBoot -> "Linux /boot"
174 | NotRoot -> "Mountable non-root"
175 | UnknownNature -> "Unknown"
176 and string_of_linux_distro = function
177 | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
178 | Fedora v -> sprintf "Fedora %d" v
179 | Debian (a,b) -> sprintf "Debian %d.%d" a b
180 | OtherLinux -> "Linux"
182 type ('a, 'b) either = Either of 'a | Or of 'b
184 (* We go into and out of newt mode at various stages, but we might
185 * also need to put up a message at any time. This keeps track of
186 * whether we are in newt mode or not.
188 * General tip: Try to do any complex operations like setting up the
189 * network or probing disks outside newt mode, and try not to throw
190 * exceptions in newt mode.
192 let in_newt = ref false
194 if !in_newt then f ()
198 try Either (Newt.init_and_finish f)
199 with exn -> Or exn in
201 match r with Either r -> r | Or exn -> raise exn
204 (* Clear the screen, open a new centered window, make sure the background
205 * and help messages are consistent.
207 let open_centered_window ?stage width height title =
208 if not !in_newt then failwith "open_centered_window: not in newt mode";
210 Newt.centered_window width height title;
212 program_name ^ (match stage with
214 | Some stage -> " - " ^ stage) in
215 Newt.draw_root_text 0 0 root_text;
216 Newt.push_help_line "F12 for next screen | [ALT] [F2] root / no password for shell"
218 (* Some general dialog boxes. *)
219 let message_box title text =
222 open_centered_window 40 20 title;
224 let textbox = Newt.textbox 1 1 36 14 [Newt.WRAP; Newt.SCROLL] in
225 Newt.textbox_set_text textbox text;
226 let ok = Newt.button 28 16 " OK " in
227 let form = Newt.form None None [] in
228 Newt.form_add_components form [textbox; 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 (* Make an SSH connection to the remote machine, execute command.
458 * The connection remains open until you call ssh_disconnect, it
459 * times out or there is some error.
461 * NB. The command is NOT quoted.
463 * Returns a pair (file descriptor, channel), both referring to the
464 * same thing. Use whichever is more convenient.
466 let ssh_connect config cmd =
467 let cmd = sprintf "ssh%s -l %s -p %s %s %s"
468 (if config.ssh_compression then " -C" else "")
469 (quote config.ssh_username) (quote config.ssh_port) (quote config.ssh_host)
471 eprintf "ssh_connect: %s\n%!" cmd;
472 let chan = open_process_out cmd in
473 descr_of_out_channel chan, chan
475 let ssh_disconnect (_, chan) =
476 eprintf "ssh_disconnect\n%!";
477 match close_process_out chan with
478 | WEXITED 0 -> () (* OK *)
479 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
480 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
481 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
483 (* Test SSH connection. *)
484 let test_ssh config =
485 printf "Testing SSH connection.\n\n%!";
487 let cmd = sprintf "/bin/ls %s" (quote config.ssh_directory) in
488 let conn = ssh_connect config cmd in
491 if !config_greeting then (
492 printf "\n\nDid SSH work?\n";
493 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
495 let line = read_line () in
496 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
501 (* Rewrite /mnt/root/etc/fstab. *)
502 let rewrite_fstab state devices_to_send =
503 let filename = "/mnt/root/etc/fstab" in
504 if is_file filename = Some true then (
505 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
507 let chan = open_in filename in
508 let lines = input_all_lines chan in
510 let lines = List.map Pcre.split lines in
511 let lines = List.map (
513 | dev :: rest when String.starts_with dev "/dev/" ->
514 let dev = String.sub dev 5 (String.length dev - 5) in
515 let dev = remote_of_origin_dev dev in
516 let dev = "/dev/" ^ dev in
521 let chan = open_out filename in
524 | [dev; mountpoint; fstype; options; freq; passno] ->
525 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
526 dev mountpoint fstype options freq passno
528 output_string chan (String.concat " " line);
529 output_char chan '\n'
534 (* Generate a random MAC address in the Xen-reserved space. *)
535 let random_mac_address () =
537 List.map (sprintf "%02x") (
538 List.map (fun _ -> Random.int 256) [0;0;0]
540 String.concat ":" ("00"::"16"::"3e"::random)
542 (* Generate a random UUID. *)
544 let hex = "0123456789abcdef" in
546 let str = String.create 32 in
547 for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
550 (*----------------------------------------------------------------------*)
551 (* Main entry point. *)
553 (* The general plan for the main function is to operate in stages:
558 * Information gathering about the system
559 * | (eg. block devices, number of CPUs, etc.)
561 * Greeting and type of transfer question
565 * | (after this point we have a working network)
568 * | (after this point we have a working SSH connection)
570 * Questions about what to transfer (block devs, root fs) <--.
573 * Questions about hypervisor configuration |
576 * Verify information -------- user wants to change info ----/
581 * Prior versions of virt-p2v (the ones which used 'dialog') had support
582 * for a back button so they could go back through dialogs. I removed
583 * this because it was hard to support and not particularly useful.
586 let rec main ttyname =
589 (* Running from an init script. We don't have much of a
590 * login environment, so set one up.
594 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
595 "/usr/bin"; "/bin"]);
596 putenv "HOME" "/root";
597 putenv "LOGNAME" "root";
599 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
602 (* Set up logging to /tmp/virt-p2v.log. *)
603 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
607 (* Log the start up time. *)
608 eprintf "\n\n**************************************************\n\n";
609 let tm = localtime (time ()) in
610 eprintf "%s starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
612 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
614 (* Connect stdin/stdout to the tty. *)
618 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
622 printf "%s starting up ...\n%!" program_name;
624 (* Disable screen blanking on tty. *)
625 sh "setterm -blank 0";
627 (* Check that the environment is a sane-looking live CD. If not, bail. *)
628 if not test_dialog_stages && is_dir "/mnt/root" <> Some true then
630 "You should only run this script from the live CD or a USB key.";
632 (* Start of the information gathering phase. *)
633 printf "Detecting hard drives (this may take some time) ...\n%!";
635 (* Search for all non-removable block devices. Do this early and bail
636 * if we can't find anything. This is a list of strings, like "hda".
638 let all_block_devices : block_device list =
639 let rex = Pcre.regexp "^[hs]d" in
640 let devices = Array.to_list (Sys.readdir "/sys/block") in
641 let devices = List.sort devices in
642 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
643 eprintf "all_block_devices: block devices: %s\n%!"
644 (String.concat "; " devices);
645 (* Run blockdev --getsize64 on each, and reject any where this fails
646 * (probably removable devices).
648 let devices = List.filter_map (
650 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
651 let lines = shget cmd in
653 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
654 | Some [] | None -> None
656 eprintf "all_block_devices: non-removable block devices: %s\n%!"
658 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
660 failwith "No non-removable block devices (hard disks, etc.) could be found on this machine.";
663 (* Search for partitions and LVs (anything that could contain a
664 * filesystem directly). We refer to these generically as
667 let all_partitions : partition list =
670 let lvs = get_lvs () in
671 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
672 let pvs = List.concat pvs in
673 let pvs = sort_uniq pvs in
674 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
675 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
676 eprintf "all_partitions: LVs: %s\n%!"
677 (String.concat "; " (List.map dev_of_partition lvs));
680 (* Partitions (eg. "sda1", "sda2"). *)
682 let parts = List.map fst all_block_devices in
683 let parts = List.map get_partitions parts in
684 let parts = List.concat parts in
685 eprintf "all_partitions: all partitions: %s\n%!"
686 (String.concat "; " (List.map dev_of_partition parts));
688 (* Remove any partitions which are PVs. *)
689 let parts = List.filter (
691 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
692 | LV _ -> assert false
695 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
696 (String.concat "; " (List.map dev_of_partition parts));
698 (* Concatenate LVs & Parts *)
701 (* Try to determine the nature of each partition.
702 * Root? Swap? Architecture? etc.
704 let all_partitions : (partition * nature) list =
705 (* Output of 'file' command for Linux swap file. *)
706 let swap = Pcre.regexp "Linux.*swap.*file" in
707 (* Contents of /etc/redhat-release. *)
708 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
709 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
710 (* Contents of /etc/debian_version. *)
711 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
712 (* Output of 'file' on certain executables. *)
713 let i386 = Pcre.regexp ", Intel 80386," in
714 let x86_64 = Pcre.regexp ", x86-64," in
715 let itanic = Pcre.regexp ", IA-64," in
717 (* Examine the filesystem mounted on 'mnt' to determine the
718 * operating system, and, if Linux, the distro.
721 if is_dir (mnt ^ "/Windows") = Some true &&
722 is_file (mnt ^ "/autoexec.bat") = Some true then
724 else if is_dir (mnt ^ "/etc") = Some true &&
725 is_dir (mnt ^ "/sbin") = Some true &&
726 is_dir (mnt ^ "/var") = Some true then (
727 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
728 let chan = open_in (mnt ^ "/etc/redhat-release") in
729 let lines = input_all_lines chan in
733 | [] -> (* empty /etc/redhat-release ...? *)
734 LinuxRoot (UnknownArch, OtherLinux)
735 | line::_ -> (* try to detect OS from /etc/redhat-release *)
737 let subs = Pcre.exec ~rex:rhel line in
738 let major = int_of_string (Pcre.get_substring subs 1) in
740 try int_of_string (Pcre.get_substring subs 2)
741 with Not_found -> 0 in
742 LinuxRoot (UnknownArch, RHEL (major, minor))
744 Not_found | Failure "int_of_string" ->
746 let subs = Pcre.exec ~rex:fedora line in
747 let version = int_of_string (Pcre.get_substring subs 1) in
748 LinuxRoot (UnknownArch, Fedora version)
750 Not_found | Failure "int_of_string" ->
751 LinuxRoot (UnknownArch, OtherLinux)
753 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
754 let chan = open_in (mnt ^ "/etc/debian_version") in
755 let lines = input_all_lines chan in
759 | [] -> (* empty /etc/debian_version ...? *)
760 LinuxRoot (UnknownArch, OtherLinux)
761 | line::_ -> (* try to detect version from /etc/debian_version *)
763 let subs = Pcre.exec ~rex:debian line in
764 let major = int_of_string (Pcre.get_substring subs 1) in
765 let minor = int_of_string (Pcre.get_substring subs 2) in
766 LinuxRoot (UnknownArch, Debian (major, minor))
768 Not_found | Failure "int_of_string" ->
769 LinuxRoot (UnknownArch, OtherLinux)
772 LinuxRoot (UnknownArch, OtherLinux)
773 ) else if is_dir (mnt ^ "/grub") = Some true &&
774 is_file (mnt ^ "/grub/stage1") = Some true then (
777 NotRoot (* mountable, but not a root filesystem *)
780 (* Examine the Linux root filesystem mounted on 'mnt' to
781 * determine the architecture. We do this by looking at some
782 * well-known binaries that we expect to be there.
784 let detect_architecture mnt =
785 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
787 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
788 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
789 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
795 let dev = dev_of_partition part in (* Get /dev device. *)
798 (* Use 'file' command to detect if it is swap. *)
799 let cmd = "file -sbL " ^ quote dev in
801 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
803 (* Blindly try to mount the device. *)
804 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
805 match shwithstatus cmd with
807 let os = detect_os "/mnt/root" in
810 | LinuxRoot (UnknownArch, distro) ->
811 let architecture = detect_architecture "/mnt/root" in
812 LinuxRoot (architecture, distro)
814 sh "umount /mnt/root";
817 | _ -> UnknownNature (* not mountable *)
821 eprintf "partition detection: %s is %s\n%!"
822 dev (string_of_nature nature);
828 printf "Finished detecting hard drives.\n%!";
830 (* Autodetect system memory. *)
832 let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
834 | Some (mem::_) -> int_of_float (float_of_string mem)
837 (* Autodetect system # pCPUs. *)
840 shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
842 | Some (cpus::_) -> int_of_string cpus
845 (* Greeting, type of transfer, network question stages.
846 * These are all done in newt mode.
848 let config_transfer_type, config_network =
852 if !config_greeting then
853 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);
855 (* Type of transfer. *)
856 let config_transfer_type =
857 match !config_transfer_type with
860 open_centered_window ~stage:"Transfer type"
861 40 10 "Transfer type";
864 Newt.radio_button 1 1 "Physical to virtual (P2V)" true
867 Newt.radio_button 1 2 "Virtual to virtual (V2V)" false
869 let ok = Newt.button 28 6 " OK " in
871 let form = Newt.form None None [] in
872 Newt.form_add_components form [p2v; v2v; ok];
876 ignore (Newt.run_form form);
878 let r = Newt.radio_get_current p2v in
879 if Newt.component_equals r p2v then P2V
880 else if Newt.component_equals r v2v then V2V
889 (* Network configuration. *)
891 match !config_network with
894 open_centered_window ~stage:"Network"
895 60 20 "Configure network";
897 let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in
898 Newt.listbox_set_width autolist 52;
900 (* Populate the "Automatic" listbox with RHEL/Fedora
901 * root partitions found which allow us to do
902 * automatic configuration in a known way.
904 let partition_map = Hashtbl.create 13 in
905 let maplen = ref 1 in
906 let rec loop = function
908 | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
912 (dev_of_partition partition)
913 (string_of_linux_distro distro) in
914 Hashtbl.add partition_map (!maplen) partition;
916 Newt.listbox_append_entry autolist label (!maplen)
920 | _ :: parts -> loop parts
924 (* If there is no suitable root partition (the listbox
925 * is empty) then disable the auto option and the listbox.
927 let no_auto = Hashtbl.length partition_map = 0 in
930 Newt.radio_button 1 1
931 "Automatic from:" (not no_auto) None in
933 Newt.radio_button 1 6
934 "Start a shell" no_auto (Some auto) in
937 Newt.component_takes_focus auto false;
938 Newt.component_takes_focus autolist false
942 Newt.radio_button 1 7
943 "QEMU user network" false (Some shell) in
945 Newt.radio_button 1 8
946 "No network or network already configured" false
949 Newt.radio_button 1 9
950 "Static configuration:" false (Some nonet) in
952 let label1 = Newt.label 4 10 "Interface" in
953 let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
954 let label2 = Newt.label 4 11 "Address" in
955 let entry2 = Newt.entry 16 11 None 16 [] in
956 let label3 = Newt.label 4 12 "Netmask" in
957 let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
958 let label4 = Newt.label 4 13 "Gateway" in
959 let entry4 = Newt.entry 16 13 None 16 [] in
960 let label5 = Newt.label 4 14 "Nameserver" in
961 let entry5 = Newt.entry 16 14 None 16 [] in
963 let enable_static () =
964 Newt.component_takes_focus entry1 true;
965 Newt.component_takes_focus entry2 true;
966 Newt.component_takes_focus entry3 true;
967 Newt.component_takes_focus entry4 true;
968 Newt.component_takes_focus entry5 true
971 let disable_static () =
972 Newt.component_takes_focus entry1 false;
973 Newt.component_takes_focus entry2 false;
974 Newt.component_takes_focus entry3 false;
975 Newt.component_takes_focus entry4 false;
976 Newt.component_takes_focus entry5 false
979 let enable_autolist () =
980 Newt.component_takes_focus autolist true
982 let disable_autolist () =
983 Newt.component_takes_focus autolist false
987 Newt.component_add_callback auto
988 (fun () ->disable_static (); enable_autolist ());
989 Newt.component_add_callback shell
990 (fun () -> disable_static (); disable_autolist ());
991 Newt.component_add_callback qemu
992 (fun () -> disable_static (); disable_autolist ());
993 Newt.component_add_callback nonet
994 (fun () -> disable_static (); disable_autolist ());
995 Newt.component_add_callback static
996 (fun () -> enable_static (); disable_autolist ());
998 let ok = Newt.button 48 16 " OK " in
1000 let form = Newt.form None None [] in
1001 Newt.form_add_components form [auto; autolist;
1002 shell;qemu;nonet;static;
1003 label1;label2;label3;label4;label5;
1004 entry1;entry2;entry3;entry4;entry5;
1009 ignore (Newt.run_form form);
1011 let r = Newt.radio_get_current auto in
1012 if Newt.component_equals r auto then (
1013 match Newt.listbox_get_current autolist with
1015 | Some i -> Auto (Hashtbl.find partition_map i)
1017 else if Newt.component_equals r shell then Shell
1018 else if Newt.component_equals r qemu then QEMUUserNet
1019 else if Newt.component_equals r nonet then NoNetwork
1020 else if Newt.component_equals r static then (
1021 let interface = Newt.entry_get_value entry1 in
1022 let address = Newt.entry_get_value entry2 in
1023 let netmask = Newt.entry_get_value entry3 in
1024 let gateway = Newt.entry_get_value entry4 in
1025 let nameserver = Newt.entry_get_value entry5 in
1026 if interface = "" || address = "" ||
1027 netmask = "" || gateway = "" then
1030 Static (interface, address, netmask, gateway, nameserver)
1039 config_transfer_type, config_network
1042 (* Try to bring up the network. *)
1043 (match config_network with
1045 printf "Network configuration.\n\n";
1046 printf "Please configure the network from this shell.\n\n";
1047 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1050 | Static (interface, address, netmask, gateway, nameserver) ->
1051 printf "Trying static network configuration.\n\n%!";
1052 if not (static_network
1053 (interface, address, netmask, gateway, nameserver)) then (
1054 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1055 printf "Please configure the network from this shell.\n\n";
1056 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1062 "Trying network auto-configuration from root filesystem ...\n\n%!";
1064 (* Mount the root filesystem read-only under /mnt/root. *)
1065 sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");
1067 if not (auto_network ()) then (
1068 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1069 printf "Please configure the network from this shell.\n\n";
1070 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1074 (* NB. Lazy unmount is required because dhclient keeps its current
1075 * directory open on /etc/sysconfig/network-scripts/
1077 sh ("umount -l /mnt/root");
1080 printf "Trying QEMU network configuration.\n\n%!";
1083 | NoNetwork -> (* this is easy ... *) ()
1086 (* SSH configuration phase. *)
1090 match !config_ssh with
1093 (* Query the user for SSH configuration. *)
1094 open_centered_window ~stage:"SSH configuration"
1095 60 20 "SSH configuration";
1097 let label1 = Newt.label 1 1 "Remote host" in
1098 let host = Newt.entry 20 1 None 36 [] in
1099 let label2 = Newt.label 1 2 "Remote port" in
1100 let port = Newt.entry 20 2 (Some "22") 6 [] in
1101 let label3 = Newt.label 1 3 "Remote directory" in
1102 let dir = Newt.entry 20 3 (Some "/var/lib/xen/images") 36 [] in
1103 let label4 = Newt.label 1 4 "SSH username" in
1104 let user = Newt.entry 20 4 (Some "root") 16 [] in
1106 There's no sensible way to support this for SSH:
1107 let label5 = Newt.label 1 5 "SSH password" in
1108 let pass = Newt.entry 20 5 None 16 [Newt.PASSWORD] in
1112 Newt.checkbox 16 7 "Use SSH compression (not good for LANs)"
1115 let check = Newt.checkbox 16 9 "Test SSH connection" '*' None in
1117 let ok = Newt.button 48 16 " OK " in
1119 let form = Newt.form None None [] in
1120 Newt.form_add_components form [label1;label2;label3;label4;
1127 ignore (Newt.run_form form);
1128 let host = Newt.entry_get_value host in
1129 let port = Newt.entry_get_value port in
1130 let dir = Newt.entry_get_value dir in
1131 let user = Newt.entry_get_value user in
1132 let compr = Newt.checkbox_get_value compr = '*' in
1133 let check = Newt.checkbox_get_value check = '*' in
1134 if host <> "" && port <> "" && user <> "" then
1135 { ssh_host = host; ssh_port = port; ssh_directory = dir;
1136 ssh_username = user;
1137 ssh_compression = compr;
1138 ssh_check = check; }
1148 (* If asked, check the SSH connection. *)
1149 if config_ssh.ssh_check then
1150 if not (test_ssh config_ssh) then
1151 failwith "SSH configuration failed";
1155 let ask_devices state =
1156 let selected_devices = Option.default [] state.devices_to_send in
1157 let devices = List.map (
1158 fun (dev, blksize) ->
1160 sprintf "/dev/%s (%.3f GB)" dev
1161 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
1162 List.mem dev selected_devices)
1163 ) all_block_devices in
1165 checklist "Devices" "Pick devices to send" 15 50 8 devices
1167 | Yes [] | No | Help | Error -> Ask_again
1168 | Yes devices -> Next { state with devices_to_send = Some devices }
1172 let ask_root state =
1173 let parts = List.mapi (
1174 fun i (part, nature) ->
1177 | LinuxSwap -> " (Linux swap)"
1178 | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
1179 | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
1180 | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
1181 | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
1182 | WindowsRoot -> " (Windows C:)"
1183 | LinuxBoot -> " (Linux /boot)"
1184 | NotRoot -> " (filesystem)"
1185 | UnknownNature -> "" in
1187 dev_of_partition part ^ descr,
1188 Some part = state.root_filesystem)
1191 radiolist "Root device"
1192 "Pick partition containing the root (/) filesystem" 18 70 9
1196 let (part, _) = List.nth all_partitions (int_of_string i) in
1197 Next { state with root_filesystem = Some part }
1198 | Yes [] | No | Help | Error -> Ask_again
1202 let ask_hypervisor state =
1204 radiolist "Hypervisor"
1205 "Choose hypervisor / virtualization system"
1207 "xen", "Xen", state.hypervisor = Some Xen;
1208 "qemu", "QEMU", state.hypervisor = Some QEMU;
1209 "kvm", "KVM", state.hypervisor = Some KVM;
1210 "other", "Other", state.hypervisor = None
1213 | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
1214 | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
1215 | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
1216 | Yes _ -> Next { state with hypervisor = None }
1217 | No | Help | Error -> Ask_again
1221 let ask_architecture state =
1223 radiolist "Architecture" "Machine architecture" 16 50 8 [
1224 "i386", "i386 and up (32 bit)", state.architecture = Some I386;
1225 "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
1226 "ia64", "Itanium IA64", state.architecture = Some IA64;
1227 "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
1228 "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
1229 "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
1230 "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
1231 "auto", "Auto-detect",
1232 state.architecture = None || state.architecture = Some UnknownArch;
1235 | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
1236 | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
1237 | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
1238 | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
1239 | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
1240 | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
1241 | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
1242 | Yes _ -> Next { state with architecture = Some UnknownArch }
1243 | No | Help | Error -> Ask_again
1247 let ask_memory state =
1249 inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
1251 (Option.map_default string_of_int "" state.memory)
1253 | Yes (""::_ | []) -> Next { state with memory = Some 0 }
1255 let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
1256 if mem < 0 || (mem > 0 && mem < 64) then Ask_again
1257 else Next { state with memory = Some mem }
1258 | No | Help | Error -> Ask_again
1262 let ask_vcpus state =
1264 inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
1266 (Option.map_default string_of_int "" state.vcpus)
1268 | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
1271 try int_of_string vcpus with Failure "int_of_string" -> -1 in
1272 if vcpus < 0 then Ask_again
1273 else Next { state with vcpus = Some vcpus }
1274 | No | Help | Error -> Ask_again
1278 let ask_mac_address state =
1280 inputbox "MAC address"
1281 "Network MAC address. Leave blank to use a random address." 10 50
1282 (Option.default "" state.mac_address)
1284 | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
1285 | Yes (mac :: _) -> Next { state with mac_address = Some mac }
1286 | No | Help | Error -> Ask_again
1290 let ask_compression state =
1292 radiolist "Network compression" "Enable network compression" 10 50 2 [
1293 "yes", "Yes, compress network traffic", state.compression <> Some false;
1294 "no", "No, don't compress", state.compression = Some false
1297 | Yes ("no"::_) -> Next { state with compression = Some false }
1298 | Yes _ -> Next { state with compression = Some true }
1299 | No | Help | Error -> Ask_again
1303 let ask_verify state =
1305 yesno "Verify and proceed"
1306 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
1319 (Option.default "" state.remote_host)
1320 (Option.default "" state.remote_port)
1321 (Option.default "" state.remote_directory)
1322 (match state.network with
1323 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
1324 | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net"
1326 (String.concat "," (Option.default [] state.devices_to_send))
1327 (Option.map_default dev_of_partition "" state.root_filesystem)
1328 (match state.hypervisor with
1329 | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
1330 | None -> "Other / not set")
1331 (match state.architecture with
1332 | Some UnknownArch -> "Auto-detect"
1333 | Some arch -> string_of_architecture arch | None -> "")
1334 (match state.memory with
1335 | Some 0 -> "Same as physical"
1336 | Some mem -> string_of_int mem ^ " MB" | None -> "")
1337 (match state.vcpus with
1338 | Some 0 -> "Same as physical"
1339 | Some vcpus -> string_of_int vcpus | None -> "")
1340 (match state.mac_address with
1341 | Some "" -> "Random" | Some mac -> mac | None -> "")
1342 (Option.default true state.compression)
1346 | Yes _ -> Next state
1348 | No | Help | Error -> Ask_again
1351 (* This is the list of dialogs, in order. The user can go forwards or
1352 * backwards through them.
1354 * The second parameter in each tuple is true if we need to skip
1355 * this dialog statically (info already supplied in 'defaults' above).
1357 * The third parameter in each tuple is a function that tests whether
1358 * this dialog should be skipped, given other parts of the current state.
1361 let dont_skip _ = false in
1363 ask_greeting, not defaults.greeting, dont_skip;
1364 ask_hostname, defaults.remote_host <> None, dont_skip;
1365 ask_port, defaults.remote_port <> None, dont_skip;
1366 ask_directory, defaults.remote_directory <> None, dont_skip;
1367 ask_username, defaults.remote_username <> None, dont_skip;
1368 ask_network, defaults.network <> None, dont_skip;
1369 ask_static_network_config,
1370 defaults.static_network_config <> None,
1371 (function { network = Some Static } -> false | _ -> true);
1372 ask_devices, defaults.devices_to_send <> None, dont_skip;
1373 ask_root, defaults.root_filesystem <> None, dont_skip;
1374 ask_hypervisor, defaults.hypervisor <> None, dont_skip;
1375 ask_architecture, defaults.architecture <> None, dont_skip;
1376 ask_memory, defaults.memory <> None, dont_skip;
1377 ask_vcpus, defaults.vcpus <> None, dont_skip;
1378 ask_mac_address, defaults.mac_address <> None, dont_skip;
1379 ask_compression, defaults.compression <> None, dont_skip;
1380 ask_verify, not defaults.greeting, dont_skip;
1383 (* Loop through the dialogs until we reach the end. *)
1384 let rec loop ?(back=false) posn state =
1385 eprintf "dialog loop: posn = %d, back = %b\n%!" posn back;
1386 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
1387 else if posn < 0 then loop 0 state
1389 let dlg, skip_static, skip_dynamic = dlgs.(posn) in
1390 if skip_static || skip_dynamic state then
1391 (* Skip this dialog. *)
1392 loop ~back (if back then posn-1 else posn+1) state
1395 match dlg state with
1396 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
1397 | Ask_again -> loop posn state (* Repeat the question. *)
1398 | Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *)
1402 let state = loop 0 defaults in
1404 eprintf "finished dialog loop\n%!";
1406 (* In test mode, exit here before we do bad things to the developer's
1409 if test_dialog_stages then exit 1;
1411 (* Switch LVM config. *)
1413 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1414 sh "rm -f /etc/lvm/cache/.cache";
1415 sh "rm -f /etc/lvm.new/cache/.cache";
1417 (* Snapshot the block devices to send. *)
1418 let devices_to_send = Option.get state.devices_to_send in
1419 let devices_to_send =
1422 let snapshot_dev = snapshot_name origin_dev in
1423 snapshot origin_dev snapshot_dev;
1424 (origin_dev, snapshot_dev)
1425 ) devices_to_send in
1427 (* Run kpartx on the snapshots. *)
1429 fun (origin, snapshot) ->
1430 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1433 (* Rescan for LVs. *)
1437 (* Mount the root filesystem under /mnt/root. *)
1438 let root_filesystem = Option.get state.root_filesystem in
1439 (match root_filesystem with
1440 | Part (dev, partnum) ->
1441 let dev = dev ^ partnum in
1442 let snapshot_dev = snapshot_name dev in
1443 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1446 (* The LV will be backed by a snapshot device, so just mount
1449 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1452 (* Work out what devices will be called at the remote end. *)
1453 let devices_to_send = List.map (
1454 fun (origin_dev, snapshot_dev) ->
1455 let remote_dev = remote_of_origin_dev origin_dev in
1456 (origin_dev, snapshot_dev, remote_dev)
1457 ) devices_to_send in
1459 (* Modify files on the root filesystem. *)
1460 rewrite_fstab state devices_to_send;
1461 (* XXX Other files to rewrite? *)
1463 (* Unmount the root filesystem and sync disks. *)
1464 sh "umount /mnt/root";
1465 sh "sync"; (* Ugh, should be in stdlib. *)
1467 (* Get architecture of root filesystem, detected previously. *)
1468 let system_architecture =
1470 (match List.assoc root_filesystem all_partitions with
1471 | LinuxRoot (arch, _) -> arch
1472 | _ -> raise Not_found
1476 (* None was detected before, so assume same as live CD. *)
1477 let arch = shget "uname -m" in
1479 | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
1480 | Some ("x86_64"::_) -> X86_64
1481 | Some ("ia64"::_) -> IA64
1482 | _ -> I386 (* probably wrong XXX *) in
1484 let remote_host = Option.get state.remote_host in
1485 let remote_port = Option.get state.remote_port in
1486 let remote_directory = Option.get state.remote_directory in
1487 let remote_username = Option.get state.remote_username in
1489 (* XXX This is using the hostname derived from network configuration
1490 * above. We might want to ask the user to choose.
1492 let hostname = safe_name (gethostname ()) in
1494 let date = sprintf "%04d%02d%02d%02d%02d"
1495 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1496 "p2v-" ^ hostname ^ "-" ^ date in
1498 (* Work out what the image filenames will be at the remote end. *)
1499 let devices_to_send = List.map (
1500 fun (origin_dev, snapshot_dev, remote_dev) ->
1501 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1502 (origin_dev, snapshot_dev, remote_dev, remote_name)
1503 ) devices_to_send in
1505 (* Write a configuration file. Not sure if this is any better than
1506 * just 'sprintf-ing' bits of XML text together, but at least we will
1507 * always get well-formed XML.
1509 * XXX For some of the stuff here we really should do a
1510 * virConnectGetCapabilities call to the remote host first.
1512 * XXX There is a case for using virt-install to generate this XML.
1513 * When we start to incorporate libvirt access & storage API this
1514 * needs to be rethought.
1516 let conf_filename = basename ^ ".conf" in
1519 match state.architecture with
1520 | Some UnknownArch | None -> system_architecture
1521 | Some arch -> arch in
1523 match state.memory with
1524 | Some 0 | None -> system_memory
1525 | Some memory -> memory in
1527 match state.vcpus with
1528 | Some 0 | None -> system_nr_cpus
1531 match state.mac_address with
1532 | Some "" | None -> random_mac_address ()
1533 | Some mac -> mac in
1536 (* Shortcut to make "<name>value</name>". *)
1537 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1538 (* ... and the _other_ sort of leaf (god I hate XML). *)
1539 let tleaf name attribs = Xml.Element (name, attribs, []) in
1541 (* Standard stuff for every domain. *)
1542 let name = leaf "name" hostname in
1543 let uuid = leaf "uuid" (random_uuid ()) in
1544 let maxmem = leaf "maxmem" (string_of_int (memory * 1024)) in
1545 let memory = leaf "memory" (string_of_int (memory * 1024)) in
1546 let vcpu = leaf "vcpu" (string_of_int vcpus) in
1548 (* Top-level stuff which differs for each HV type (isn't this supposed
1549 * to be portable ...)
1552 match state.hypervisor with
1554 [Xml.Element ("os", [],
1556 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1557 tleaf "boot" ["dev", "hd"]]);
1558 Xml.Element ("features", [],
1562 tleaf "clock" ["sync", "localtime"]]
1564 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1565 tleaf "clock" ["sync", "localtime"]]
1567 [Xml.Element ("os", [],
1568 [Xml.Element ("type",
1570 string_of_architecture architecture;
1572 [Xml.PCData "hvm"]);
1573 tleaf "boot" ["dev", "hd"]])]
1577 (* <devices> section. *)
1580 match state.hypervisor with
1582 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1584 [leaf "emulator" "/usr/bin/qemu"]
1586 [leaf "emulator" "/usr/bin/qemu-kvm"]
1590 Xml.Element ("interface", ["type", "user"],
1591 [tleaf "mac" ["address", mac_address]]) in
1592 (* XXX should have an option for Xen bridging:
1594 "interface", ["type","bridge"],
1595 [tleaf "source" ["bridge","xenbr0"];
1596 tleaf "mac" ["address",mac_address];
1597 tleaf "script" ["path","vif-bridge"]])*)
1598 let graphics = tleaf "graphics" ["type", "vnc"] in
1600 let disks = List.map (
1601 fun (_, _, remote_dev, remote_name) ->
1603 "disk", ["type", "file";
1605 [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1606 tleaf "target" ["dev", remote_dev]]
1608 ) devices_to_send in
1612 emulator @ interface :: graphics :: disks
1615 (* Put it all together in <domain type='foo'>. *)
1618 (match state.hypervisor with
1619 | Some Xen -> ["type", "xen"]
1620 | Some QEMU -> ["type", "qemu"]
1621 | Some KVM -> ["type", "kvm"]
1623 name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
1626 (* Convert XML configuration file to a string, then send it to the
1630 let xml = Xml.to_string_fmt xml in
1633 match state.hypervisor with
1634 | Some Xen | None -> ""
1635 | Some QEMU | Some KVM -> " -c qemu:///system" in
1636 let xml = sprintf "\
1638 This is a libvirt configuration file.
1640 To start the domain, do:
1643 -->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in
1645 let xml_len = String.length xml in
1646 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1648 let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1649 (* In OCaml this actually loops calling write(2) *)
1650 ignore (write sock xml 0 xml_len);
1651 do_disconnect conn in
1653 (* Send the device snapshots to the remote host. *)
1654 (* XXX This code should be made more robust against both network
1655 * errors and local I/O errors. Also should allow the user several
1656 * attempts to connect, or let them go back to the dialog stage.
1659 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1660 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1663 try List.assoc origin_dev all_block_devices
1664 with Not_found -> assert false (* internal error *) in
1666 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1667 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1669 (* Open the snapshot device. *)
1670 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1673 let (sock,_) as conn = do_connect remote_name size in
1675 (* Copy the data. *)
1676 let spinners = "|/-\\" (* "Oo" *) in
1677 let bufsize = 1024 * 1024 in
1678 let buffer = String.create bufsize in
1679 let start = gettimeofday () in
1681 let rec copy bytes_sent last_printed_at spinner =
1682 let n = read fd buffer 0 bufsize in
1684 let n' = write sock buffer 0 n in
1685 if n <> n' then assert false; (* never, according to the manual *)
1687 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1688 let last_printed_at, spinner =
1689 let now = gettimeofday () in
1690 (* Print progress every few seconds. *)
1691 if now -. last_printed_at > 2. then (
1692 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1693 let secs_elapsed = now -. start in
1694 printf "%.0f%% %c %.1f Mbps"
1695 (100. *. elapsed) spinners.[spinner]
1696 (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
1697 (* After 60 seconds has elapsed, start printing estimates. *)
1698 if secs_elapsed >= 60. then (
1699 let remaining = 1. -. elapsed in
1700 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1701 if secs_remaining > 120. then
1702 printf " (about %.0f minutes remaining)" (secs_remaining/.60.)
1704 printf " (about %.0f seconds remaining)"
1708 let spinner = (spinner + 1) mod String.length spinners in
1711 else last_printed_at, spinner in
1713 copy bytes_sent last_printed_at spinner
1717 printf "\n\n%!"; (* because of the messages printed above *)
1723 (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
1725 (* Clean up and reboot. *)
1727 msgbox (sprintf "%s completed" program_name)
1728 (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."
1729 remote_directory conf_filename)
1738 (*----------------------------------------------------------------------*)
1741 eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
1744 (* Make sure that exceptions from 'main' get printed out on stdout
1745 * as well as stderr, since stderr is probably redirected to the
1746 * logfile, and so not visible to the user.
1748 let handle_exn f arg =
1751 print_endline (Printexc.to_string exn);
1754 (* Test harness for the Makefile. The Makefile invokes this script as
1755 * 'virt-p2v --test' just to check it compiles. When it is running
1756 * from the actual live CD, there is a single parameter which is the
1757 * tty name (so usually 'virt-p2v tty1').
1760 match Array.to_list Sys.argv with
1761 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1762 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1763 | [ _; ttyname ] -> (* Run main with ttyname. *)
1764 handle_exn main (Some ttyname)
1765 | [ _ ] -> (* Interactive - no ttyname. *)
1766 handle_exn main None
1769 (* This file must end with a newline *)