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_check : bool; (* If true, check SSH is working. *)
45 ssh_libvirtd : bool; (* If true, contact remote libvirtd. *)
52 | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
56 (*----------------------------------------------------------------------*)
57 (* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section.
59 * If left as they are, then this will create a generic virt-p2v script
60 * which asks the user for each question. If you set the defaults here
61 * then you will get a custom virt-p2v which is partially or even fully
62 * automated and won't ask the user any questions.
64 * Note that 'None' means 'no default' (ie. ask the user) whereas
65 * 'Some foo' means use 'foo' as the answer.
67 * These are documented in the virt-p2v(1) manual page.
69 * After changing them, run './virt-p2v --test' to check syntax.
72 (* If greeting is true, wait for keypress after boot and during
73 * final verification. Set to 'false' for less interactions.
75 let config_greeting = ref true
77 (* General type of transfer. *)
78 let config_transfer_type = ref None
80 (* Network configuration. *)
81 let config_network = ref None
83 (* SSH configuration. *)
84 let config_ssh = ref None
86 (* What to transfer. *)
87 let config_devices_to_send = ref None
88 let config_root_filesystem = ref None
90 (* Configuration of the target. *)
91 let config_hypervisor = ref None
92 let config_architecture = ref None
93 let config_memory = ref None
94 let config_vcpus = ref None
95 let config_mac_address = ref None
96 let config_compression = 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 (* Rewrite /mnt/root/etc/fstab. *)
460 let rewrite_fstab state devices_to_send =
461 let filename = "/mnt/root/etc/fstab" in
462 if is_file filename = Some true then (
463 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
465 let chan = open_in filename in
466 let lines = input_all_lines chan in
468 let lines = List.map Pcre.split lines in
469 let lines = List.map (
471 | dev :: rest when String.starts_with dev "/dev/" ->
472 let dev = String.sub dev 5 (String.length dev - 5) in
473 let dev = remote_of_origin_dev dev in
474 let dev = "/dev/" ^ dev in
479 let chan = open_out filename in
482 | [dev; mountpoint; fstype; options; freq; passno] ->
483 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
484 dev mountpoint fstype options freq passno
486 output_string chan (String.concat " " line);
487 output_char chan '\n'
492 (* Generate a random MAC address in the Xen-reserved space. *)
493 let random_mac_address () =
495 List.map (sprintf "%02x") (
496 List.map (fun _ -> Random.int 256) [0;0;0]
498 String.concat ":" ("00"::"16"::"3e"::random)
500 (* Generate a random UUID. *)
502 let hex = "0123456789abcdef" in
504 let str = String.create 32 in
505 for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
508 (*----------------------------------------------------------------------*)
509 (* Main entry point. *)
511 (* The general plan for the main function is to operate in stages:
516 * Information gathering about the system
517 * | (eg. block devices, number of CPUs, etc.)
519 * Greeting and type of transfer question
523 * | (after this point we have a working network)
526 * | (after this point we have a working SSH connection)
528 * Questions about what to transfer (block devs, root fs) <--.
531 * Questions about hypervisor configuration |
534 * Verify information -------- user wants to change info ----/
539 * Prior versions of virt-p2v (the ones which used 'dialog') had support
540 * for a back button so they could go back through dialogs. I removed
541 * this because it was hard to support and not particularly useful.
544 let rec main ttyname =
547 (* Running from an init script. We don't have much of a
548 * login environment, so set one up.
552 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
553 "/usr/bin"; "/bin"]);
554 putenv "HOME" "/root";
555 putenv "LOGNAME" "root";
557 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
560 (* Set up logging to /tmp/virt-p2v.log. *)
561 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
565 (* Log the start up time. *)
566 eprintf "\n\n**************************************************\n\n";
567 let tm = localtime (time ()) in
568 eprintf "%s starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
570 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
572 (* Connect stdin/stdout to the tty. *)
576 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
580 printf "%s starting up ...\n%!" program_name;
582 (* Disable screen blanking on tty. *)
583 sh "setterm -blank 0";
585 (* Check that the environment is a sane-looking live CD. If not, bail. *)
586 if not test_dialog_stages && is_dir "/mnt/root" <> Some true then
588 "You should only run this script from the live CD or a USB key.";
590 (* Start of the information gathering phase. *)
591 printf "%s detecting hard drives (this may take some time) ...\n%!"
594 (* Search for all non-removable block devices. Do this early and bail
595 * if we can't find anything. This is a list of strings, like "hda".
597 let all_block_devices : block_device list =
598 let rex = Pcre.regexp "^[hs]d" in
599 let devices = Array.to_list (Sys.readdir "/sys/block") in
600 let devices = List.sort devices in
601 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
602 eprintf "all_block_devices: block devices: %s\n%!"
603 (String.concat "; " devices);
604 (* Run blockdev --getsize64 on each, and reject any where this fails
605 * (probably removable devices).
607 let devices = List.filter_map (
609 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
610 let lines = shget cmd in
612 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
613 | Some [] | None -> None
615 eprintf "all_block_devices: non-removable block devices: %s\n%!"
617 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
619 failwith "No non-removable block devices (hard disks, etc.) could be found on this machine.";
622 (* Search for partitions and LVs (anything that could contain a
623 * filesystem directly). We refer to these generically as
626 let all_partitions : partition list =
629 let lvs = get_lvs () in
630 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
631 let pvs = List.concat pvs in
632 let pvs = sort_uniq pvs in
633 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
634 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
635 eprintf "all_partitions: LVs: %s\n%!"
636 (String.concat "; " (List.map dev_of_partition lvs));
639 (* Partitions (eg. "sda1", "sda2"). *)
641 let parts = List.map fst all_block_devices in
642 let parts = List.map get_partitions parts in
643 let parts = List.concat parts in
644 eprintf "all_partitions: all partitions: %s\n%!"
645 (String.concat "; " (List.map dev_of_partition parts));
647 (* Remove any partitions which are PVs. *)
648 let parts = List.filter (
650 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
651 | LV _ -> assert false
654 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
655 (String.concat "; " (List.map dev_of_partition parts));
657 (* Concatenate LVs & Parts *)
660 (* Try to determine the nature of each partition.
661 * Root? Swap? Architecture? etc.
663 let all_partitions : (partition * nature) list =
664 (* Output of 'file' command for Linux swap file. *)
665 let swap = Pcre.regexp "Linux.*swap.*file" in
666 (* Contents of /etc/redhat-release. *)
667 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
668 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
669 (* Contents of /etc/debian_version. *)
670 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
671 (* Output of 'file' on certain executables. *)
672 let i386 = Pcre.regexp ", Intel 80386," in
673 let x86_64 = Pcre.regexp ", x86-64," in
674 let itanic = Pcre.regexp ", IA-64," in
676 (* Examine the filesystem mounted on 'mnt' to determine the
677 * operating system, and, if Linux, the distro.
680 if is_dir (mnt ^ "/Windows") = Some true &&
681 is_file (mnt ^ "/autoexec.bat") = Some true then
683 else if is_dir (mnt ^ "/etc") = Some true &&
684 is_dir (mnt ^ "/sbin") = Some true &&
685 is_dir (mnt ^ "/var") = Some true then (
686 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
687 let chan = open_in (mnt ^ "/etc/redhat-release") in
688 let lines = input_all_lines chan in
692 | [] -> (* empty /etc/redhat-release ...? *)
693 LinuxRoot (UnknownArch, OtherLinux)
694 | line::_ -> (* try to detect OS from /etc/redhat-release *)
696 let subs = Pcre.exec ~rex:rhel line in
697 let major = int_of_string (Pcre.get_substring subs 1) in
699 try int_of_string (Pcre.get_substring subs 2)
700 with Not_found -> 0 in
701 LinuxRoot (UnknownArch, RHEL (major, minor))
703 Not_found | Failure "int_of_string" ->
705 let subs = Pcre.exec ~rex:fedora line in
706 let version = int_of_string (Pcre.get_substring subs 1) in
707 LinuxRoot (UnknownArch, Fedora version)
709 Not_found | Failure "int_of_string" ->
710 LinuxRoot (UnknownArch, OtherLinux)
712 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
713 let chan = open_in (mnt ^ "/etc/debian_version") in
714 let lines = input_all_lines chan in
718 | [] -> (* empty /etc/debian_version ...? *)
719 LinuxRoot (UnknownArch, OtherLinux)
720 | line::_ -> (* try to detect version from /etc/debian_version *)
722 let subs = Pcre.exec ~rex:debian line in
723 let major = int_of_string (Pcre.get_substring subs 1) in
724 let minor = int_of_string (Pcre.get_substring subs 2) in
725 LinuxRoot (UnknownArch, Debian (major, minor))
727 Not_found | Failure "int_of_string" ->
728 LinuxRoot (UnknownArch, OtherLinux)
731 LinuxRoot (UnknownArch, OtherLinux)
732 ) else if is_dir (mnt ^ "/grub") = Some true &&
733 is_file (mnt ^ "/grub/stage1") = Some true then (
736 NotRoot (* mountable, but not a root filesystem *)
739 (* Examine the Linux root filesystem mounted on 'mnt' to
740 * determine the architecture. We do this by looking at some
741 * well-known binaries that we expect to be there.
743 let detect_architecture mnt =
744 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
746 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
747 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
748 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
754 let dev = dev_of_partition part in (* Get /dev device. *)
757 (* Use 'file' command to detect if it is swap. *)
758 let cmd = "file -sbL " ^ quote dev in
760 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
762 (* Blindly try to mount the device. *)
763 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
764 match shwithstatus cmd with
766 let os = detect_os "/mnt/root" in
769 | LinuxRoot (UnknownArch, distro) ->
770 let architecture = detect_architecture "/mnt/root" in
771 LinuxRoot (architecture, distro)
773 sh "umount /mnt/root";
776 | _ -> UnknownNature (* not mountable *)
780 eprintf "partition detection: %s is %s\n%!"
781 dev (string_of_nature nature);
787 printf "finished detecting hard drives\n%!";
789 (* Autodetect system memory. *)
791 let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
793 | Some (mem::_) -> int_of_float (float_of_string mem)
796 (* Autodetect system # pCPUs. *)
799 shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
801 | Some (cpus::_) -> int_of_string cpus
804 (* Greeting, type of transfer, network question stages.
805 * These are all done in newt mode.
807 let config_transfer_type, config_network =
811 if !config_greeting then
812 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);
814 (* Type of transfer. *)
815 let config_transfer_type =
816 match !config_transfer_type with
819 open_centered_window ~stage:"Transfer type"
820 40 10 "Transfer type";
823 Newt.radio_button 1 1 "Physical to virtual (P2V)" true
826 Newt.radio_button 1 2 "Virtual to virtual (V2V)" false
828 let ok = Newt.button 28 6 " OK " in
830 let form = Newt.form None None [] in
831 Newt.form_add_components form [p2v; v2v];
832 Newt.form_add_component form ok;
836 ignore (Newt.run_form form);
838 let r = Newt.radio_get_current p2v in
839 if Newt.component_equals r p2v then P2V
840 else if Newt.component_equals r v2v then V2V
849 (* Network configuration. *)
851 match !config_network with
854 open_centered_window ~stage:"Network"
855 60 20 "Configure network";
857 let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in
858 Newt.listbox_set_width autolist 52;
860 (* Populate the "Automatic" listbox with RHEL/Fedora
861 * root partitions found which allow us to do
862 * automatic configuration in a known way.
864 let partition_map = Hashtbl.create 13 in
865 let maplen = ref 1 in
866 let rec loop = function
868 | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))
872 (dev_of_partition partition)
873 (string_of_linux_distro distro) in
874 Hashtbl.add partition_map (!maplen) partition;
876 Newt.listbox_append_entry autolist label (!maplen)
880 | _ :: parts -> loop parts
884 (* If there is no suitable root partition (the listbox
885 * is empty) then disable the auto option and the listbox.
887 let no_auto = Hashtbl.length partition_map = 0 in
890 Newt.radio_button 1 1
891 "Automatic from:" (not no_auto) None in
893 Newt.radio_button 1 6
894 "Start a shell" no_auto (Some auto) in
897 Newt.component_takes_focus auto false;
898 Newt.component_takes_focus autolist false
902 Newt.radio_button 1 7
903 "QEMU user network" false (Some shell) in
905 Newt.radio_button 1 8
906 "No network or network already configured" false
909 Newt.radio_button 1 9
910 "Static configuration:" false (Some nonet) in
912 let label1 = Newt.label 4 10 "Interface" in
913 let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in
914 let label2 = Newt.label 4 11 "Address" in
915 let entry2 = Newt.entry 16 11 None 16 [] in
916 let label3 = Newt.label 4 12 "Netmask" in
917 let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in
918 let label4 = Newt.label 4 13 "Gateway" in
919 let entry4 = Newt.entry 16 13 None 16 [] in
920 let label5 = Newt.label 4 14 "Nameserver" in
921 let entry5 = Newt.entry 16 14 None 16 [] in
923 let enable_static () =
924 Newt.component_takes_focus entry1 true;
925 Newt.component_takes_focus entry2 true;
926 Newt.component_takes_focus entry3 true;
927 Newt.component_takes_focus entry4 true;
928 Newt.component_takes_focus entry5 true
931 let disable_static () =
932 Newt.component_takes_focus entry1 false;
933 Newt.component_takes_focus entry2 false;
934 Newt.component_takes_focus entry3 false;
935 Newt.component_takes_focus entry4 false;
936 Newt.component_takes_focus entry5 false
939 let enable_autolist () =
940 Newt.component_takes_focus autolist true
942 let disable_autolist () =
943 Newt.component_takes_focus autolist false
947 Newt.component_add_callback auto
948 (fun () ->disable_static (); enable_autolist ());
949 Newt.component_add_callback shell
950 (fun () -> disable_static (); disable_autolist ());
951 Newt.component_add_callback qemu
952 (fun () -> disable_static (); disable_autolist ());
953 Newt.component_add_callback nonet
954 (fun () -> disable_static (); disable_autolist ());
955 Newt.component_add_callback static
956 (fun () -> enable_static (); disable_autolist ());
958 let ok = Newt.button 48 16 " OK " in
960 let form = Newt.form None None [] in
961 Newt.form_add_component form auto;
962 Newt.form_add_component form autolist;
963 Newt.form_add_components form [shell;qemu;nonet;static];
964 Newt.form_add_components form
965 [label1;label2;label3;label4;label5];
966 Newt.form_add_components form
967 [entry1;entry2;entry3;entry4;entry5];
968 Newt.form_add_component form ok;
972 ignore (Newt.run_form form);
974 let r = Newt.radio_get_current auto in
975 if Newt.component_equals r auto then (
976 match Newt.listbox_get_current autolist with
978 | Some i -> Auto (Hashtbl.find partition_map i)
980 else if Newt.component_equals r shell then Shell
981 else if Newt.component_equals r qemu then QEMUUserNet
982 else if Newt.component_equals r nonet then NoNetwork
983 else if Newt.component_equals r static then (
984 let interface = Newt.entry_get_value entry1 in
985 let address = Newt.entry_get_value entry2 in
986 let netmask = Newt.entry_get_value entry3 in
987 let gateway = Newt.entry_get_value entry4 in
988 let nameserver = Newt.entry_get_value entry5 in
989 if interface = "" || address = "" ||
990 netmask = "" || gateway = "" then
993 Static (interface, address, netmask, gateway, nameserver)
1002 config_transfer_type, config_network
1005 (* Try to bring up the network. *)
1006 (match config_network with
1008 printf "Network configuration.\n\n";
1009 printf "Please configure the network from this shell.\n\n";
1010 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1013 | Static (interface, address, netmask, gateway, nameserver) ->
1014 printf "Trying static network configuration.\n\n%!";
1015 if not (static_network
1016 (interface, address, netmask, gateway, nameserver)) then (
1017 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1018 printf "Please configure the network from this shell.\n\n";
1019 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1025 "Trying network auto-configuration from root filesystem ...\n\n%!";
1027 (* Mount the root filesystem read-only under /mnt/root. *)
1028 sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root");
1030 if not (auto_network ()) then (
1031 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1032 printf "Please configure the network from this shell.\n\n";
1033 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1037 (* NB. Lazy unmount is required because dhclient keeps its current
1038 * directory open on /etc/sysconfig/network-scripts/
1040 sh ("umount -l /mnt/root");
1043 printf "Trying QEMU network configuration.\n\n%!";
1046 | NoNetwork -> (* this is easy ... *) ()
1049 (* SSH configuration phase. *)
1053 match !config_ssh with
1056 (* Query the user for SSH configuration. *)
1057 open_centered_window ~stage:"SSH configuration"
1058 60 15 "SSH configuration";
1060 let label1 = Newt.label 1 1 "Remote host" in
1061 let host = Newt.entry 20 1 None 36 [] in
1062 let label2 = Newt.label 1 2 "Remote port" in
1063 let port = Newt.entry 20 2 (Some "22") 6 [] in
1064 let label3 = Newt.label 1 3 "Remote directory" in
1065 let dir = Newt.entry 20 3 (Some "/var/lib/xen/images") 36 [] in
1066 let label4 = Newt.label 1 4 "SSH username" in
1067 let user = Newt.entry 20 4 (Some "root") 16 [] in
1068 let label5 = Newt.label 1 5 "SSH password" in
1069 let pass = Newt.entry 20 5 None 16 [] in
1071 let check = Newt.checkbox 17 7 "Test SSH connection" '*' None in
1073 Newt.checkbox 17 8 "libvirtd is running on host" '*' None in
1075 Newt.component_add_callback check
1077 if Newt.checkbox_get_value check = '*' then
1078 Newt.component_takes_focus libvirtd true
1080 Newt.component_takes_focus libvirtd false;
1081 Newt.checkbox_set_value libvirtd ' '
1085 let ok = Newt.button 48 11 " OK " in
1087 let form = Newt.form None None [] in
1088 Newt.form_add_components form [label1;label2;label3;label4;label5];
1089 Newt.form_add_components form [host;port;dir;user;pass];
1090 Newt.form_add_components form [check;libvirtd];
1091 Newt.form_add_component form ok;
1095 ignore (Newt.run_form form);
1097 let host = Newt.entry_get_value host in
1098 let port = int_of_string (Newt.entry_get_value port) in
1099 let dir = Newt.entry_get_value dir in
1100 let user = Newt.entry_get_value user in
1101 let pass = Newt.entry_get_value pass in
1102 let check = Newt.checkbox_get_value check = '*' in
1103 let libvirtd = Newt.checkbox_get_value libvirtd = '*' in
1104 if host <> "" && port > 0 && port < 65536 &&
1106 { ssh_host = host; ssh_port = port; ssh_directory = dir;
1107 ssh_username = user; ssh_password = pass;
1108 ssh_check = check; ssh_libvirtd = libvirtd }
1112 Failure "int_of_string" -> loop ()
1123 let ask_devices state =
1124 let selected_devices = Option.default [] state.devices_to_send in
1125 let devices = List.map (
1126 fun (dev, blksize) ->
1128 sprintf "/dev/%s (%.3f GB)" dev
1129 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
1130 List.mem dev selected_devices)
1131 ) all_block_devices in
1133 checklist "Devices" "Pick devices to send" 15 50 8 devices
1135 | Yes [] | No | Help | Error -> Ask_again
1136 | Yes devices -> Next { state with devices_to_send = Some devices }
1140 let ask_root state =
1141 let parts = List.mapi (
1142 fun i (part, nature) ->
1145 | LinuxSwap -> " (Linux swap)"
1146 | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
1147 | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
1148 | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
1149 | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
1150 | WindowsRoot -> " (Windows C:)"
1151 | LinuxBoot -> " (Linux /boot)"
1152 | NotRoot -> " (filesystem)"
1153 | UnknownNature -> "" in
1155 dev_of_partition part ^ descr,
1156 Some part = state.root_filesystem)
1159 radiolist "Root device"
1160 "Pick partition containing the root (/) filesystem" 18 70 9
1164 let (part, _) = List.nth all_partitions (int_of_string i) in
1165 Next { state with root_filesystem = Some part }
1166 | Yes [] | No | Help | Error -> Ask_again
1170 let ask_hypervisor state =
1172 radiolist "Hypervisor"
1173 "Choose hypervisor / virtualization system"
1175 "xen", "Xen", state.hypervisor = Some Xen;
1176 "qemu", "QEMU", state.hypervisor = Some QEMU;
1177 "kvm", "KVM", state.hypervisor = Some KVM;
1178 "other", "Other", state.hypervisor = None
1181 | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
1182 | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
1183 | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
1184 | Yes _ -> Next { state with hypervisor = None }
1185 | No | Help | Error -> Ask_again
1189 let ask_architecture state =
1191 radiolist "Architecture" "Machine architecture" 16 50 8 [
1192 "i386", "i386 and up (32 bit)", state.architecture = Some I386;
1193 "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
1194 "ia64", "Itanium IA64", state.architecture = Some IA64;
1195 "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
1196 "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
1197 "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
1198 "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
1199 "auto", "Auto-detect",
1200 state.architecture = None || state.architecture = Some UnknownArch;
1203 | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
1204 | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
1205 | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
1206 | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
1207 | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
1208 | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
1209 | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
1210 | Yes _ -> Next { state with architecture = Some UnknownArch }
1211 | No | Help | Error -> Ask_again
1215 let ask_memory state =
1217 inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
1219 (Option.map_default string_of_int "" state.memory)
1221 | Yes (""::_ | []) -> Next { state with memory = Some 0 }
1223 let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
1224 if mem < 0 || (mem > 0 && mem < 64) then Ask_again
1225 else Next { state with memory = Some mem }
1226 | No | Help | Error -> Ask_again
1230 let ask_vcpus state =
1232 inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
1234 (Option.map_default string_of_int "" state.vcpus)
1236 | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
1239 try int_of_string vcpus with Failure "int_of_string" -> -1 in
1240 if vcpus < 0 then Ask_again
1241 else Next { state with vcpus = Some vcpus }
1242 | No | Help | Error -> Ask_again
1246 let ask_mac_address state =
1248 inputbox "MAC address"
1249 "Network MAC address. Leave blank to use a random address." 10 50
1250 (Option.default "" state.mac_address)
1252 | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
1253 | Yes (mac :: _) -> Next { state with mac_address = Some mac }
1254 | No | Help | Error -> Ask_again
1258 let ask_compression state =
1260 radiolist "Network compression" "Enable network compression" 10 50 2 [
1261 "yes", "Yes, compress network traffic", state.compression <> Some false;
1262 "no", "No, don't compress", state.compression = Some false
1265 | Yes ("no"::_) -> Next { state with compression = Some false }
1266 | Yes _ -> Next { state with compression = Some true }
1267 | No | Help | Error -> Ask_again
1271 let ask_verify state =
1273 yesno "Verify and proceed"
1274 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
1287 (Option.default "" state.remote_host)
1288 (Option.default "" state.remote_port)
1289 (Option.default "" state.remote_directory)
1290 (match state.network with
1291 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
1292 | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net"
1294 (String.concat "," (Option.default [] state.devices_to_send))
1295 (Option.map_default dev_of_partition "" state.root_filesystem)
1296 (match state.hypervisor with
1297 | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
1298 | None -> "Other / not set")
1299 (match state.architecture with
1300 | Some UnknownArch -> "Auto-detect"
1301 | Some arch -> string_of_architecture arch | None -> "")
1302 (match state.memory with
1303 | Some 0 -> "Same as physical"
1304 | Some mem -> string_of_int mem ^ " MB" | None -> "")
1305 (match state.vcpus with
1306 | Some 0 -> "Same as physical"
1307 | Some vcpus -> string_of_int vcpus | None -> "")
1308 (match state.mac_address with
1309 | Some "" -> "Random" | Some mac -> mac | None -> "")
1310 (Option.default true state.compression)
1314 | Yes _ -> Next state
1316 | No | Help | Error -> Ask_again
1319 (* This is the list of dialogs, in order. The user can go forwards or
1320 * backwards through them.
1322 * The second parameter in each tuple is true if we need to skip
1323 * this dialog statically (info already supplied in 'defaults' above).
1325 * The third parameter in each tuple is a function that tests whether
1326 * this dialog should be skipped, given other parts of the current state.
1329 let dont_skip _ = false in
1331 ask_greeting, not defaults.greeting, dont_skip;
1332 ask_hostname, defaults.remote_host <> None, dont_skip;
1333 ask_port, defaults.remote_port <> None, dont_skip;
1334 ask_directory, defaults.remote_directory <> None, dont_skip;
1335 ask_username, defaults.remote_username <> None, dont_skip;
1336 ask_network, defaults.network <> None, dont_skip;
1337 ask_static_network_config,
1338 defaults.static_network_config <> None,
1339 (function { network = Some Static } -> false | _ -> true);
1340 ask_devices, defaults.devices_to_send <> None, dont_skip;
1341 ask_root, defaults.root_filesystem <> None, dont_skip;
1342 ask_hypervisor, defaults.hypervisor <> None, dont_skip;
1343 ask_architecture, defaults.architecture <> None, dont_skip;
1344 ask_memory, defaults.memory <> None, dont_skip;
1345 ask_vcpus, defaults.vcpus <> None, dont_skip;
1346 ask_mac_address, defaults.mac_address <> None, dont_skip;
1347 ask_compression, defaults.compression <> None, dont_skip;
1348 ask_verify, not defaults.greeting, dont_skip;
1351 (* Loop through the dialogs until we reach the end. *)
1352 let rec loop ?(back=false) posn state =
1353 eprintf "dialog loop: posn = %d, back = %b\n%!" posn back;
1354 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
1355 else if posn < 0 then loop 0 state
1357 let dlg, skip_static, skip_dynamic = dlgs.(posn) in
1358 if skip_static || skip_dynamic state then
1359 (* Skip this dialog. *)
1360 loop ~back (if back then posn-1 else posn+1) state
1363 match dlg state with
1364 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
1365 | Ask_again -> loop posn state (* Repeat the question. *)
1366 | Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *)
1370 let state = loop 0 defaults in
1372 eprintf "finished dialog loop\n%!";
1374 (* In test mode, exit here before we do bad things to the developer's
1377 if test_dialog_stages then exit 1;
1379 (* Switch LVM config. *)
1381 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1382 sh "rm -f /etc/lvm/cache/.cache";
1383 sh "rm -f /etc/lvm.new/cache/.cache";
1385 (* Snapshot the block devices to send. *)
1386 let devices_to_send = Option.get state.devices_to_send in
1387 let devices_to_send =
1390 let snapshot_dev = snapshot_name origin_dev in
1391 snapshot origin_dev snapshot_dev;
1392 (origin_dev, snapshot_dev)
1393 ) devices_to_send in
1395 (* Run kpartx on the snapshots. *)
1397 fun (origin, snapshot) ->
1398 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1401 (* Rescan for LVs. *)
1405 (* Mount the root filesystem under /mnt/root. *)
1406 let root_filesystem = Option.get state.root_filesystem in
1407 (match root_filesystem with
1408 | Part (dev, partnum) ->
1409 let dev = dev ^ partnum in
1410 let snapshot_dev = snapshot_name dev in
1411 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1414 (* The LV will be backed by a snapshot device, so just mount
1417 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1420 (* Work out what devices will be called at the remote end. *)
1421 let devices_to_send = List.map (
1422 fun (origin_dev, snapshot_dev) ->
1423 let remote_dev = remote_of_origin_dev origin_dev in
1424 (origin_dev, snapshot_dev, remote_dev)
1425 ) devices_to_send in
1427 (* Modify files on the root filesystem. *)
1428 rewrite_fstab state devices_to_send;
1429 (* XXX Other files to rewrite? *)
1431 (* Unmount the root filesystem and sync disks. *)
1432 sh "umount /mnt/root";
1433 sh "sync"; (* Ugh, should be in stdlib. *)
1435 (* Get architecture of root filesystem, detected previously. *)
1436 let system_architecture =
1438 (match List.assoc root_filesystem all_partitions with
1439 | LinuxRoot (arch, _) -> arch
1440 | _ -> raise Not_found
1444 (* None was detected before, so assume same as live CD. *)
1445 let arch = shget "uname -m" in
1447 | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
1448 | Some ("x86_64"::_) -> X86_64
1449 | Some ("ia64"::_) -> IA64
1450 | _ -> I386 (* probably wrong XXX *) in
1452 let remote_host = Option.get state.remote_host in
1453 let remote_port = Option.get state.remote_port in
1454 let remote_directory = Option.get state.remote_directory in
1455 let remote_username = Option.get state.remote_username in
1457 (* Functions to connect and disconnect from the remote system. *)
1458 let do_connect remote_name _ =
1459 let cmd = sprintf "ssh%s -l %s -p %s %s \"cat > %s/%s\""
1460 (if state.compression = Some false then "" else " -C")
1461 (quote remote_username) (quote remote_port) (quote remote_host)
1462 (quote remote_directory) (quote remote_name) in
1463 eprintf "connect: %s\n%!" cmd;
1464 let chan = open_process_out cmd in
1465 descr_of_out_channel chan, chan
1467 let do_disconnect (_, chan) =
1468 match close_process_out chan with
1469 | WEXITED 0 -> () (* OK *)
1470 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
1471 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
1472 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
1475 (* XXX This is using the hostname derived from network configuration
1476 * above. We might want to ask the user to choose.
1478 let hostname = safe_name (gethostname ()) in
1480 let date = sprintf "%04d%02d%02d%02d%02d"
1481 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1482 "p2v-" ^ hostname ^ "-" ^ date in
1484 (* Work out what the image filenames will be at the remote end. *)
1485 let devices_to_send = List.map (
1486 fun (origin_dev, snapshot_dev, remote_dev) ->
1487 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1488 (origin_dev, snapshot_dev, remote_dev, remote_name)
1489 ) devices_to_send in
1491 (* Write a configuration file. Not sure if this is any better than
1492 * just 'sprintf-ing' bits of XML text together, but at least we will
1493 * always get well-formed XML.
1495 * XXX For some of the stuff here we really should do a
1496 * virConnectGetCapabilities call to the remote host first.
1498 * XXX There is a case for using virt-install to generate this XML.
1499 * When we start to incorporate libvirt access & storage API this
1500 * needs to be rethought.
1502 let conf_filename = basename ^ ".conf" in
1505 match state.architecture with
1506 | Some UnknownArch | None -> system_architecture
1507 | Some arch -> arch in
1509 match state.memory with
1510 | Some 0 | None -> system_memory
1511 | Some memory -> memory in
1513 match state.vcpus with
1514 | Some 0 | None -> system_nr_cpus
1517 match state.mac_address with
1518 | Some "" | None -> random_mac_address ()
1519 | Some mac -> mac in
1522 (* Shortcut to make "<name>value</name>". *)
1523 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1524 (* ... and the _other_ sort of leaf (god I hate XML). *)
1525 let tleaf name attribs = Xml.Element (name, attribs, []) in
1527 (* Standard stuff for every domain. *)
1528 let name = leaf "name" hostname in
1529 let uuid = leaf "uuid" (random_uuid ()) in
1530 let maxmem = leaf "maxmem" (string_of_int (memory * 1024)) in
1531 let memory = leaf "memory" (string_of_int (memory * 1024)) in
1532 let vcpu = leaf "vcpu" (string_of_int vcpus) in
1534 (* Top-level stuff which differs for each HV type (isn't this supposed
1535 * to be portable ...)
1538 match state.hypervisor with
1540 [Xml.Element ("os", [],
1542 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1543 tleaf "boot" ["dev", "hd"]]);
1544 Xml.Element ("features", [],
1548 tleaf "clock" ["sync", "localtime"]]
1550 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1551 tleaf "clock" ["sync", "localtime"]]
1553 [Xml.Element ("os", [],
1554 [Xml.Element ("type",
1556 string_of_architecture architecture;
1558 [Xml.PCData "hvm"]);
1559 tleaf "boot" ["dev", "hd"]])]
1563 (* <devices> section. *)
1566 match state.hypervisor with
1568 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1570 [leaf "emulator" "/usr/bin/qemu"]
1572 [leaf "emulator" "/usr/bin/qemu-kvm"]
1576 Xml.Element ("interface", ["type", "user"],
1577 [tleaf "mac" ["address", mac_address]]) in
1578 (* XXX should have an option for Xen bridging:
1580 "interface", ["type","bridge"],
1581 [tleaf "source" ["bridge","xenbr0"];
1582 tleaf "mac" ["address",mac_address];
1583 tleaf "script" ["path","vif-bridge"]])*)
1584 let graphics = tleaf "graphics" ["type", "vnc"] in
1586 let disks = List.map (
1587 fun (_, _, remote_dev, remote_name) ->
1589 "disk", ["type", "file";
1591 [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1592 tleaf "target" ["dev", remote_dev]]
1594 ) devices_to_send in
1598 emulator @ interface :: graphics :: disks
1601 (* Put it all together in <domain type='foo'>. *)
1604 (match state.hypervisor with
1605 | Some Xen -> ["type", "xen"]
1606 | Some QEMU -> ["type", "qemu"]
1607 | Some KVM -> ["type", "kvm"]
1609 name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
1612 (* Convert XML configuration file to a string, then send it to the
1616 let xml = Xml.to_string_fmt xml in
1619 match state.hypervisor with
1620 | Some Xen | None -> ""
1621 | Some QEMU | Some KVM -> " -c qemu:///system" in
1622 let xml = sprintf "\
1624 This is a libvirt configuration file.
1626 To start the domain, do:
1629 -->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in
1631 let xml_len = String.length xml in
1632 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1634 let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1635 (* In OCaml this actually loops calling write(2) *)
1636 ignore (write sock xml 0 xml_len);
1637 do_disconnect conn in
1639 (* Send the device snapshots to the remote host. *)
1640 (* XXX This code should be made more robust against both network
1641 * errors and local I/O errors. Also should allow the user several
1642 * attempts to connect, or let them go back to the dialog stage.
1645 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1646 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1649 try List.assoc origin_dev all_block_devices
1650 with Not_found -> assert false (* internal error *) in
1652 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1653 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1655 (* Open the snapshot device. *)
1656 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1659 let (sock,_) as conn = do_connect remote_name size in
1661 (* Copy the data. *)
1662 let spinners = "|/-\\" (* "Oo" *) in
1663 let bufsize = 1024 * 1024 in
1664 let buffer = String.create bufsize in
1665 let start = gettimeofday () in
1667 let rec copy bytes_sent last_printed_at spinner =
1668 let n = read fd buffer 0 bufsize in
1670 let n' = write sock buffer 0 n in
1671 if n <> n' then assert false; (* never, according to the manual *)
1673 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1674 let last_printed_at, spinner =
1675 let now = gettimeofday () in
1676 (* Print progress every few seconds. *)
1677 if now -. last_printed_at > 2. then (
1678 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1679 let secs_elapsed = now -. start in
1680 printf "%.0f%% %c %.1f Mbps"
1681 (100. *. elapsed) spinners.[spinner]
1682 (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
1683 (* After 60 seconds has elapsed, start printing estimates. *)
1684 if secs_elapsed >= 60. then (
1685 let remaining = 1. -. elapsed in
1686 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1687 if secs_remaining > 120. then
1688 printf " (about %.0f minutes remaining)" (secs_remaining/.60.)
1690 printf " (about %.0f seconds remaining)"
1694 let spinner = (spinner + 1) mod String.length spinners in
1697 else last_printed_at, spinner in
1699 copy bytes_sent last_printed_at spinner
1703 printf "\n\n%!"; (* because of the messages printed above *)
1709 (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
1711 (* Clean up and reboot. *)
1713 msgbox (sprintf "%s completed" program_name)
1714 (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."
1715 remote_directory conf_filename)
1724 (*----------------------------------------------------------------------*)
1727 eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
1730 (* Make sure that exceptions from 'main' get printed out on stdout
1731 * as well as stderr, since stderr is probably redirected to the
1732 * logfile, and so not visible to the user.
1734 let handle_exn f arg =
1737 print_endline (Printexc.to_string exn);
1740 (* Test harness for the Makefile. The Makefile invokes this script as
1741 * 'virt-p2v --test' just to check it compiles. When it is running
1742 * from the actual live CD, there is a single parameter which is the
1743 * tty name (so usually 'virt-p2v tty1').
1746 match Array.to_list Sys.argv with
1747 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1748 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1749 | [ _; ttyname ] -> (* Run main with ttyname. *)
1750 handle_exn main (Some ttyname)
1751 | [ _ ] -> (* Interactive - no ttyname. *)
1752 handle_exn main None
1755 (* This file must end with a newline *)