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 #directory "+extlib";;
29 #directory "+xml-light";;
30 #load "xml-light.cma";;
37 type state = { greeting : bool;
38 remote_host : string option; remote_port : string option;
39 remote_directory : string option;
40 remote_username : string option;
41 network : network option;
42 devices_to_send : string list option;
43 root_filesystem : partition option;
44 hypervisor : hypervisor option;
45 architecture : architecture option;
46 memory : int option; vcpus : int option;
47 mac_address : string option;
49 and network = Auto | Shell
50 and partition = Part of string * string (* eg. "hda", "1" *)
51 | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
52 and hypervisor = Xen | QEMU | KVM
53 and architecture = I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
54 | OtherArch of string | UnknownArch
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.
68 (* If greeting is true, wait for keypress after boot and during
69 * final verification. Set to 'false' for less interactions.
73 (* These are now documented in the man page virt-p2v(1).
74 * 'None' means ask the user.
75 * After changing them, run './virt-p2v --test' to check syntax.
79 remote_directory = None;
80 remote_username = None;
81 devices_to_send = None;
82 root_filesystem = None;
90 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
91 (*----------------------------------------------------------------------*)
93 (* General helper functions. *)
95 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
96 let xs = List.sort ~cmp xs in
97 let rec loop = function
98 | [] -> [] | [x] -> [x]
99 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
100 | x :: xs -> x :: loop xs
104 let input_all_lines chan =
105 let lines = ref [] in
107 while true do lines := input_line chan :: !lines done; []
109 End_of_file -> List.rev !lines
111 let dev_of_partition = function
112 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
113 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
115 let string_of_architecture = function
122 | SPARC64 -> "sparc64"
123 | OtherArch arch -> arch
126 type dialog_status = Yes of string list | No | Help | Back | Error
128 type ask_result = Next of state | Prev | Ask_again
130 type nature = LinuxSwap
131 | LinuxRoot of architecture * linux_distro
132 | WindowsRoot (* Windows C: *)
133 | LinuxBoot (* Linux /boot *)
134 | NotRoot (* mountable, but not / or /boot *)
136 and linux_distro = RHEL of int * int
138 | Debian of int * int
141 let rec string_of_nature = function
142 | LinuxSwap -> "Linux swap"
143 | LinuxRoot (architecture, distro) ->
144 string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
145 | WindowsRoot -> "Windows root"
146 | LinuxBoot -> "Linux /boot"
147 | NotRoot -> "Mountable non-root"
148 | UnknownNature -> "Unknown"
149 and string_of_linux_distro = function
150 | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
151 | Fedora v -> sprintf "Fedora %d" v
152 | Debian (a,b) -> sprintf "Debian %d.%d" a b
153 | OtherLinux -> "Linux"
157 * Each function takes some common parameters (eg. ~title) and some
158 * dialog-specific parameters.
160 * Returns the exit status (Yes lines | No | Help | Back | Error).
162 let msgbox, yesno, inputbox, radiolist, checklist =
163 (* Internal function to actually run the "dialog" shell command. *)
164 let run_dialog cparams params =
165 let params = cparams @ params in
166 eprintf "dialog %s\n%!"
167 (String.concat " " (List.map (sprintf "%S") params));
169 (* 'dialog' writes its output/result to stderr, so we need to take
170 * special steps to capture that - in other words, manual pipe/fork.
172 let rfd, wfd = pipe () in
174 | 0 -> (* child, runs dialog *)
176 dup2 wfd stderr; (* capture stderr to pipe *)
177 execvp "dialog" (Array.of_list ("dialog" :: params))
178 | pid -> (* parent *)
180 let chan = in_channel_of_descr rfd in
181 let result = input_all_lines chan in
183 eprintf "dialog result: %S\n%!" (String.concat "\n" result);
184 match snd (wait ()) with
185 | WEXITED 0 -> Yes result (* something selected / entered *)
186 | WEXITED 1 -> No (* cancel / no button *)
187 | WEXITED 2 -> Help (* help pressed *)
188 | WEXITED 3 -> Back (* back button *)
189 | WEXITED _ -> Error (* error or Esc *)
190 | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
191 | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
194 (* Handle the common parameters. Note Continuation Passing Style. *)
195 let with_common cont ?(cancel=false) ?(backbutton=true) title =
196 let params = ["--title"; title] in
197 let params = if not cancel then "--nocancel" :: params else params in
199 if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
204 (* Message box and yes/no box. *)
207 fun cparams text height width ->
209 [ "--msgbox"; text; string_of_int height; string_of_int width ]
213 fun cparams text height width ->
215 [ "--yesno"; text; string_of_int height; string_of_int width ]
218 (* Simple input box. *)
221 fun cparams text height width default ->
223 [ "--inputbox"; text; string_of_int height; string_of_int width;
227 (* Radio list and check list. *)
230 fun cparams text height width listheight items ->
231 let items = List.map (
233 | tag, item, true -> [ tag; item; "on" ]
234 | tag, item, false -> [ tag; item; "off" ]
236 let items = List.concat items in
237 let items = "--single-quoted" ::
238 "--radiolist" :: text ::
239 string_of_int height :: string_of_int width ::
240 string_of_int listheight :: items in
241 run_dialog cparams items
245 fun cparams text height width listheight items ->
246 let items = List.map (
248 | tag, item, true -> [ tag; item; "on" ]
249 | tag, item, false -> [ tag; item; "off" ]
251 let items = List.concat items in
252 let items = "--separate-output" ::
253 "--checklist" :: text ::
254 string_of_int height :: string_of_int width ::
255 string_of_int listheight :: items in
256 run_dialog cparams items
259 msgbox, yesno, inputbox, radiolist, checklist
261 (* Print failure dialog and exit. *)
262 let fail_dialog text =
263 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
264 ignore (msgbox "Error" text 17 50);
267 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
268 let quote = Filename.quote
270 (* Run a shell command and check it returns 0. *)
272 eprintf "sh: %s\n%!" cmd;
273 if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
276 eprintf "shfailok: %s\n%!" cmd;
277 ignore (Sys.command cmd)
279 let shwithstatus cmd =
280 eprintf "shwithstatus: %s\n%!" cmd;
283 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
285 eprintf "shget: %s\n%!" cmd;
286 let chan = open_process_in cmd in
287 let lines = input_all_lines chan in
288 match close_process_in chan with
289 | WEXITED 0 -> Some lines (* command succeeded *)
290 | WEXITED _ -> None (* command failed *)
291 | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
292 | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
294 (* Start an interactive shell. Need to juggle file descriptors a bit
295 * because bash write PS1 to stderr (currently directed to the logfile).
299 | 0 -> (* child, runs bash *)
302 (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
304 Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
306 | _ -> (* parent, waits *)
307 eprintf "waiting for subshell to exit\n%!";
310 (* Some true if is dir/file, Some false if not, None if not found. *)
312 try Some ((stat path).st_kind = S_DIR)
313 with Unix_error (ENOENT, "stat", _) -> None
315 try Some ((stat path).st_kind = S_REG)
316 with Unix_error (ENOENT, "stat", _) -> None
318 (* Useful regular expression. *)
319 let whitespace = Pcre.regexp "[ \t]+"
321 (* Generate a predictable safe name containing only letters, numbers
322 * and underscores. If passed a string with no letters or numbers,
323 * generates "_1", "_2", etc.
328 fun () -> incr i; "_" ^ string_of_int !i
331 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
332 let name = String.copy name in
333 let have_safe = ref false in
334 for i = 0 to String.length name - 1 do
335 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
337 if !have_safe then name else next_anon ()
339 type block_device = string * int64 (* "hda" & size in bytes *)
341 (* Parse the output of 'lvs' to get list of LV names, sizes,
342 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
345 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
349 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
353 let lines = List.map (Pcre.split ~rex:whitespace) lines in
356 | [vg; lv; pvs; lvsize]
357 | [_; vg; lv; pvs; lvsize] ->
358 let pvs = String.nsplit pvs "," in
359 let pvs = List.filter_map (
362 let subs = Pcre.exec ~rex:devname pv in
363 Some (Pcre.get_substring subs 1)
366 eprintf "lvs: unexpected device name: %s\n%!" pv;
369 LV (vg, lv), pvs, lvsize
371 failwith ("lvs: unexpected output: " ^ String.concat "," line)
374 (* Get the partitions on a block device.
375 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
377 let get_partitions dev =
378 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
379 let devdir = "/sys/block/" ^ dev in
380 let parts = Sys.readdir devdir in
381 let parts = Array.to_list parts in
382 let parts = List.filter (
383 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
385 let parts = List.filter_map (
388 let subs = Pcre.exec ~rex part in
389 Some (Part (dev, Pcre.get_substring subs 1))
395 (* Generate snapshot device name from device name. *)
396 let snapshot_name dev =
397 "snap" ^ (safe_name dev)
399 (* Perform a device-mapper snapshot with ramdisk overlay. *)
401 let next_free_ram_disk =
403 fun () -> incr i; "/dev/ram" ^ string_of_int !i
405 fun origin_dev snapshot_dev ->
406 let ramdisk = next_free_ram_disk () in
408 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
409 let lines = shget cmd in
411 | Some (sectors::_) -> Int64.of_string sectors
413 fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
415 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
416 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
417 snapshot_dev sectors origin_dev);
418 (* Create the snapshot. *)
419 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
420 snapshot_dev sectors snapshot_dev ramdisk)
422 (* Try to perform automatic network configuration, assuming a Fedora or
423 * RHEL-like root filesystem mounted on /mnt/root.
425 let auto_network state =
426 (* Fedora gives an error if this file doesn't exist. *)
427 sh "touch /etc/resolv.conf";
430 (* We can run /mnt/root/etc/init.d/network in a chroot environment,
431 * however this won't work directly because the architecture of the
432 * binaries under /mnt/root (eg. /mnt/root/sbin/ip) might not match
433 * the architecture of the live CD kernel. In particular, a 32 bit
434 * live CD cannot run 64 bit binaries. So we also have to bind-mount
435 * the live CD's /bin, /sbin, /lib etc. over the equivalents in
439 if is_dir dir = Some true then
440 sh ("mount -o bind " ^ quote dir ^ " " ^ quote ("/mnt/root" ^ dir))
443 if is_dir dir = Some true then sh ("umount -l " ^ quote ("/mnt/root" ^ dir))
446 "/bin"; "/sbin"; "/lib"; "/lib64";
447 "/usr/bin"; "/usr/sbin"; "/usr/lib"; "/usr/lib64";
451 let status = shwithstatus "chroot /mnt/root /etc/init.d/network start" in
452 List.iter unbind dirs;
455 (* Simpler way to do the above.
456 * NB. Lazy unmount is required because dhclient keeps its current
457 * directory open on /etc/sysconfig/network-scripts/
459 sh "mount -o bind /mnt/root/etc /etc";
460 let status = shwithstatus "/etc/init.d/network start" in
463 (* Try to ping the remote host to see if this worked. *)
464 shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
466 if state.greeting then (
467 printf "\n\nDid automatic network configuration work?\n";
468 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
470 let line = read_line () in
471 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
474 (* Non-interactive: return the status of /etc/init.d/network start. *)
477 (* Map local device names to remote devices names. At the moment we
478 * just change sd* to hd* (as device names appear under fullvirt). In
479 * future, lots of complex possibilities.
481 let remote_of_origin_dev =
482 let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
483 let devsd_subst = Pcre.subst "hd$1" in
485 Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
487 (* Rewrite /mnt/root/etc/fstab. *)
488 let rewrite_fstab state devices_to_send =
489 let filename = "/mnt/root/etc/fstab" in
490 if is_file filename = Some true then (
491 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
493 let chan = open_in filename in
494 let lines = input_all_lines chan in
496 let lines = List.map (Pcre.split ~rex:whitespace) lines in
497 let lines = List.map (
499 | dev :: rest when String.starts_with dev "/dev/" ->
500 let dev = String.sub dev 5 (String.length dev - 5) in
501 let dev = remote_of_origin_dev dev in
502 let dev = "/dev/" ^ dev in
507 let chan = open_out filename in
510 | [dev; mountpoint; fstype; options; freq; passno] ->
511 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
512 dev mountpoint fstype options freq passno
514 output_string chan (String.concat " " line)
519 (* Main entry point. *)
520 let rec main ttyname =
521 (* Running from an init script. We don't have much of a
522 * login environment, so set one up.
526 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
527 "/usr/bin"; "/bin"]);
528 putenv "HOME" "/root";
529 putenv "LOGNAME" "root";
531 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
534 (* Set up logging to /tmp/virt-p2v.log. *)
535 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
539 (* Log the start up time. *)
540 eprintf "\n\n**************************************************\n\n";
541 let tm = localtime (time ()) in
542 eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
543 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
545 (* Connect stdin/stdout to the tty. *)
549 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
553 printf "virt-p2v starting up ...\n%!";
555 (* Disable screen blanking on tty. *)
556 sh "setterm -blank 0";
558 (* Check that the environment is a sane-looking live CD. If not, bail. *)
559 if is_dir "/mnt/root" <> Some true then
561 "You should only run this script from the live CD or a USB key.";
563 printf "virt-p2v detecting hard drives (this may take some time) ...\n%!";
565 (* Search for all non-removable block devices. Do this early and bail
566 * if we can't find anything. This is a list of strings, like "hda".
568 let all_block_devices : block_device list =
569 let rex = Pcre.regexp "^[hs]d" in
570 let devices = Array.to_list (Sys.readdir "/sys/block") in
571 let devices = List.sort devices in
572 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
573 eprintf "all_block_devices: block devices: %s\n%!"
574 (String.concat "; " devices);
575 (* Run blockdev --getsize64 on each, and reject any where this fails
576 * (probably removable devices).
578 let devices = List.filter_map (
580 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
581 let lines = shget cmd in
583 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
584 | Some [] | None -> None
586 eprintf "all_block_devices: non-removable block devices: %s\n%!"
588 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
590 fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
593 (* Search for partitions and LVs (anything that could contain a
594 * filesystem directly). We refer to these generically as
597 let all_partitions : partition list =
600 let lvs = get_lvs () in
601 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
602 let pvs = List.concat pvs in
603 let pvs = sort_uniq pvs in
604 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
605 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
606 eprintf "all_partitions: LVs: %s\n%!"
607 (String.concat "; " (List.map dev_of_partition lvs));
610 (* Partitions (eg. "sda1", "sda2"). *)
612 let parts = List.map fst all_block_devices in
613 let parts = List.map get_partitions parts in
614 let parts = List.concat parts in
615 eprintf "all_partitions: all partitions: %s\n%!"
616 (String.concat "; " (List.map dev_of_partition parts));
618 (* Remove any partitions which are PVs. *)
619 let parts = List.filter (
621 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
622 | LV _ -> assert false
625 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
626 (String.concat "; " (List.map dev_of_partition parts));
628 (* Concatenate LVs & Parts *)
631 (* Try to determine the nature of each partition.
632 * Root? Swap? Architecture? etc.
634 let all_partitions : (partition * nature) list =
635 (* Output of 'file' command for Linux swap file. *)
636 let swap = Pcre.regexp "Linux.*swap.*file" in
637 (* Contents of /etc/redhat-release. *)
638 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
639 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
640 (* Contents of /etc/debian_version. *)
641 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
642 (* Output of 'file' on certain executables. *)
643 let i386 = Pcre.regexp ", Intel 80386," in
644 let x86_64 = Pcre.regexp ", x86-64," in
645 let itanic = Pcre.regexp ", IA-64," in
647 (* Examine the filesystem mounted on 'mnt' to determine the
648 * operating system, and, if Linux, the distro.
651 if is_dir (mnt ^ "/Windows") = Some true &&
652 is_file (mnt ^ "/autoexec.bat") = Some true then
654 else if is_dir (mnt ^ "/etc") = Some true &&
655 is_dir (mnt ^ "/sbin") = Some true &&
656 is_dir (mnt ^ "/var") = Some true then (
657 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
658 let chan = open_in (mnt ^ "/etc/redhat-release") in
659 let lines = input_all_lines chan in
663 | [] -> (* empty /etc/redhat-release ...? *)
664 LinuxRoot (UnknownArch, OtherLinux)
665 | line::_ -> (* try to detect OS from /etc/redhat-release *)
667 let subs = Pcre.exec ~rex:rhel line in
668 let major = int_of_string (Pcre.get_substring subs 1) in
670 try int_of_string (Pcre.get_substring subs 2)
671 with Not_found -> 0 in
672 LinuxRoot (UnknownArch, RHEL (major, minor))
674 Not_found | Failure "int_of_string" ->
676 let subs = Pcre.exec ~rex:fedora line in
677 let version = int_of_string (Pcre.get_substring subs 1) in
678 LinuxRoot (UnknownArch, Fedora version)
680 Not_found | Failure "int_of_string" ->
681 LinuxRoot (UnknownArch, OtherLinux)
683 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
684 let chan = open_in (mnt ^ "/etc/debian_version") in
685 let lines = input_all_lines chan in
689 | [] -> (* empty /etc/debian_version ...? *)
690 LinuxRoot (UnknownArch, OtherLinux)
691 | line::_ -> (* try to detect version from /etc/debian_version *)
693 let subs = Pcre.exec ~rex:debian line in
694 let major = int_of_string (Pcre.get_substring subs 1) in
695 let minor = int_of_string (Pcre.get_substring subs 2) in
696 LinuxRoot (UnknownArch, Debian (major, minor))
698 Not_found | Failure "int_of_string" ->
699 LinuxRoot (UnknownArch, OtherLinux)
702 LinuxRoot (UnknownArch, OtherLinux)
703 ) else if is_dir (mnt ^ "/grub") = Some true &&
704 is_file (mnt ^ "/grub/stage1") = Some true then (
707 NotRoot (* mountable, but not a root filesystem *)
710 (* Examine the Linux root filesystem mounted on 'mnt' to
711 * determine the architecture. We do this by looking at some
712 * well-known binaries that we expect to be there.
714 let detect_architecture mnt =
715 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
717 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
718 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
719 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
725 let dev = dev_of_partition part in (* Get /dev device. *)
728 (* Use 'file' command to detect if it is swap. *)
729 let cmd = "file -sbL " ^ quote dev in
731 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
733 (* Blindly try to mount the device. *)
734 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
735 match shwithstatus cmd with
737 let os = detect_os "/mnt/root" in
740 | LinuxRoot (UnknownArch, distro) ->
741 let architecture = detect_architecture "/mnt/root" in
742 LinuxRoot (architecture, distro)
744 sh "umount /mnt/root";
747 | _ -> UnknownNature (* not mountable *)
751 eprintf "partition detection: %s is %s\n%!"
752 dev (string_of_nature nature);
758 printf "virt-p2v finished detecting hard drives\n%!";
761 let ask_greeting state =
762 ignore (msgbox "virt-p2v" "\nWelcome to virt-p2v, 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." 18 50);
766 let ask_hostname state =
768 inputbox "Remote host" "Remote host" 10 50
769 (Option.default "" state.remote_host)
771 | Yes [] -> Ask_again
772 | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
773 | No | Help | Error -> Ask_again
779 inputbox "Remote port" "Remote port" 10 50
780 (Option.default "22" state.remote_port)
782 | Yes ([]|""::_) -> Next { state with remote_port = Some "22" }
783 | Yes (port::_) -> Next { state with remote_port = Some port }
784 | No | Help | Error -> Ask_again
788 let ask_directory state =
789 let default_dir = "/var/lib/xen/images" in
791 inputbox "Remote directory" "Remote directory" 10 50
792 (Option.default default_dir state.remote_directory)
794 | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir }
795 | Yes (dir::_) -> Next { state with remote_directory = Some dir }
796 | No | Help | Error -> Ask_again
800 let ask_username state =
801 let default_username = "root" in
803 inputbox "Remote username" "Remote username for ssh access to server" 10 50
804 (Option.default default_username state.remote_username)
807 Next { state with remote_username = Some default_username }
808 | Yes (user::_) -> Next { state with remote_username = Some user }
809 | No | Help | Error -> Ask_again
813 let ask_network state =
815 radiolist "Network configuration" "Network configuration" 10 50 2 [
816 "auto", "Automatic configuration", state.network = Some Auto;
817 "sh", "Configure from the shell", state.network = Some Shell;
820 | Yes ("auto"::_) -> Next { state with network = Some Auto }
821 | Yes ("sh"::_) -> Next { state with network = Some Shell }
822 | Yes _ | No | Help | Error -> Ask_again
826 let ask_devices state =
827 let selected_devices = Option.default [] state.devices_to_send in
828 let devices = List.map (
829 fun (dev, blksize) ->
831 sprintf "/dev/%s (%.3f GB)" dev
832 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
833 List.mem dev selected_devices)
834 ) all_block_devices in
836 checklist "Devices" "Pick devices to send" 15 50 8 devices
838 | Yes [] | No | Help | Error -> Ask_again
839 | Yes devices -> Next { state with devices_to_send = Some devices }
844 let parts = List.mapi (
845 fun i (part, nature) ->
848 | LinuxSwap -> " (Linux swap)"
849 | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
850 | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
851 | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
852 | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
853 | WindowsRoot -> " (Windows C:)"
854 | LinuxBoot -> " (Linux /boot)"
855 | NotRoot -> " (filesystem)"
856 | UnknownNature -> "" in
858 dev_of_partition part ^ descr,
859 Some part = state.root_filesystem)
862 radiolist "Root device"
863 "Pick partition containing the root (/) filesystem" 18 70 9
867 let (part, _) = List.nth all_partitions (int_of_string i) in
868 Next { state with root_filesystem = Some part }
869 | Yes [] | No | Help | Error -> Ask_again
873 let ask_hypervisor state =
875 radiolist "Hypervisor"
876 "Choose hypervisor / virtualization system"
878 "xen", "Xen", state.hypervisor = Some Xen;
879 "qemu", "QEMU", state.hypervisor = Some QEMU;
880 "kvm", "KVM", state.hypervisor = Some KVM;
881 "other", "Other", state.hypervisor = None
884 | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
885 | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
886 | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
887 | Yes _ -> Next { state with hypervisor = None }
888 | No | Help | Error -> Ask_again
892 let ask_architecture state =
894 radiolist "Architecture" "Machine architecture" 16 50 8 [
895 "i386", "i386 and up (32 bit)", state.architecture = Some I386;
896 "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
897 "ia64", "Itanium IA64", state.architecture = Some IA64;
898 "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
899 "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
900 "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
901 "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
902 "auto", "Auto-detect",
903 state.architecture = None || state.architecture = Some UnknownArch;
906 | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
907 | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
908 | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
909 | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
910 | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
911 | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
912 | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
913 | Yes _ -> Next { state with architecture = Some UnknownArch }
914 | No | Help | Error -> Ask_again
918 let ask_memory state =
920 inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
922 (Option.map_default string_of_int "" state.memory)
924 | Yes (""::_ | []) -> Next { state with memory = Some 0 }
926 let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
927 if mem < 0 || (mem > 0 && mem < 64) then Ask_again
928 else Next { state with memory = Some mem }
929 | No | Help | Error -> Ask_again
933 let ask_vcpus state =
935 inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
937 (Option.map_default string_of_int "" state.vcpus)
939 | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
942 try int_of_string vcpus with Failure "int_of_string" -> -1 in
943 if vcpus < 0 then Ask_again
944 else Next { state with vcpus = Some vcpus }
945 | No | Help | Error -> Ask_again
949 let ask_mac_address state =
951 inputbox "MAC address"
952 "Network MAC address. Leave blank to use a random address." 10 50
953 (Option.default "" state.mac_address)
955 | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
956 | Yes (mac :: _) -> Next { state with mac_address = Some mac }
957 | No | Help | Error -> Ask_again
961 let ask_verify state =
963 yesno "Verify and proceed"
964 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
976 (Option.default "" state.remote_host)
977 (Option.default "" state.remote_port)
978 (Option.default "" state.remote_directory)
979 (match state.network with
980 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
982 (String.concat "," (Option.default [] state.devices_to_send))
983 (Option.map_default dev_of_partition "" state.root_filesystem)
984 (match state.hypervisor with
985 | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
986 | None -> "Other / not set")
987 (match state.architecture with
988 | Some UnknownArch -> "Auto-detect"
989 | Some arch -> string_of_architecture arch | None -> "")
990 (match state.memory with
991 | Some 0 -> "Same as physical"
992 | Some mem -> string_of_int mem ^ " MB" | None -> "")
993 (match state.vcpus with
994 | Some 0 -> "Same as physical"
995 | Some vcpus -> string_of_int vcpus | None -> "")
996 (match state.mac_address with
997 | Some "" -> "Random" | Some mac -> mac | None -> "")
1001 | Yes _ -> Next state
1003 | No | Help | Error -> Ask_again
1006 (* This is the list of dialogs, in order. The user can go forwards or
1007 * backwards through them. The second parameter in each pair is
1008 * false if we need to skip this dialog (info already supplied in
1009 * 'defaults' above).
1012 ask_greeting, (* Initial greeting. *)
1014 ask_hostname, (* Hostname. *)
1015 defaults.remote_host = None;
1016 ask_port, (* Port number. *)
1017 defaults.remote_port = None;
1018 ask_directory, (* Remote directory. *)
1019 defaults.remote_directory = None;
1020 ask_username, (* Remote username. *)
1021 defaults.remote_username = None;
1022 ask_network, (* Network configuration. *)
1023 defaults.network = None;
1024 ask_devices, (* Block devices to send. *)
1025 defaults.devices_to_send = None;
1026 ask_root, (* Root filesystem. *)
1027 defaults.root_filesystem = None;
1028 ask_hypervisor, (* Hypervisor. *)
1029 defaults.hypervisor = None;
1030 ask_architecture, (* Architecture. *)
1031 defaults.architecture = None;
1032 ask_memory, (* Memory. *)
1033 defaults.memory = None;
1034 ask_vcpus, (* VCPUs. *)
1035 defaults.vcpus = None;
1036 ask_mac_address, (* MAC address. *)
1037 defaults.mac_address = None;
1038 ask_verify, (* Verify settings. *)
1042 (* Loop through the dialogs until we reach the end. *)
1043 let rec loop posn state =
1044 eprintf "dialog loop: posn = %d\n%!" posn;
1045 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
1047 let dlg, no_skip = dlgs.(posn) in
1048 let skip = not no_skip in
1050 (* Skip this dialog and move straight to the next one. *)
1054 match dlg state with
1055 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
1056 | Prev -> loop (posn-1) state (* Backwards / back button. *)
1057 | Ask_again -> loop posn state (* Repeat the question. *)
1061 let state = loop 0 defaults in
1063 eprintf "finished dialog loop\n%!";
1065 (* Switch LVM config. *)
1067 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1068 sh "rm -f /etc/lvm/cache/.cache";
1069 sh "rm -f /etc/lvm.new/cache/.cache";
1071 (* Snapshot the block devices to send. *)
1072 let devices_to_send = Option.get state.devices_to_send in
1073 let devices_to_send =
1076 let snapshot_dev = snapshot_name origin_dev in
1077 snapshot origin_dev snapshot_dev;
1078 (origin_dev, snapshot_dev)
1079 ) devices_to_send in
1081 (* Run kpartx on the snapshots. *)
1083 fun (origin, snapshot) ->
1084 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1087 (* Rescan for LVs. *)
1091 (* Mount the root filesystem under /mnt/root. *)
1092 let root_filesystem = Option.get state.root_filesystem in
1093 (match root_filesystem with
1094 | Part (dev, partnum) ->
1095 let dev = dev ^ partnum in
1096 let snapshot_dev = snapshot_name dev in
1097 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1100 (* The LV will be backed by a snapshot device, so just mount
1103 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1106 (* See if we can do network configuration. *)
1107 let network = Option.get state.network in
1110 printf "Network configuration.\n\n";
1111 printf "Please configure the network from this shell.\n\n";
1112 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1117 "Trying network auto-configuration from root filesystem ...\n\n%!";
1118 if not (auto_network state) then (
1119 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1120 printf "Please configure the network from this shell.\n\n";
1121 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1126 (* Work out what devices will be called at the remote end. *)
1127 let devices_to_send = List.map (
1128 fun (origin_dev, snapshot_dev) ->
1129 let remote_dev = remote_of_origin_dev origin_dev in
1130 (origin_dev, snapshot_dev, remote_dev)
1131 ) devices_to_send in
1133 (* Modify files on the root filesystem. *)
1134 rewrite_fstab state devices_to_send;
1135 (* XXX Other files to rewrite? *)
1137 (* Unmount the root filesystem and sync disks. *)
1138 sh "umount /mnt/root";
1139 sh "sync"; (* Ugh, should be in stdlib. *)
1141 (* Get architecture of root filesystem, detected previously. *)
1142 let system_architecture =
1144 (match List.assoc root_filesystem all_partitions with
1145 | LinuxRoot (arch, _) -> arch
1146 | _ -> raise Not_found
1150 (* None was detected before, so assume same as live CD. *)
1151 let arch = shget "uname -m" in
1153 | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
1154 | Some ("x86_64"::_) -> X86_64
1155 | Some ("ia64"::_) -> IA64
1156 | _ -> I386 (* probably wrong XXX *) in
1158 (* Autodetect system memory. *)
1160 let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
1162 | Some (mem::_) -> int_of_float (float_of_string mem)
1165 (* Autodetect system # pCPUs. *)
1166 let system_nr_cpus =
1168 shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
1170 | Some (cpus::_) -> int_of_string cpus
1173 let remote_host = Option.get state.remote_host in
1174 let remote_port = Option.get state.remote_port in
1175 let remote_directory = Option.get state.remote_directory in
1176 let remote_username = Option.get state.remote_username in
1178 (* Functions to connect and disconnect from the remote system. *)
1179 let do_connect remote_name _ =
1180 let cmd = sprintf "ssh -C -l %s -p %s %s \"cat > %s/%s\""
1181 (quote remote_username) (quote remote_port) (quote remote_host)
1182 (quote remote_directory) (quote remote_name) in
1183 eprintf "connect: %s\n%!" cmd;
1184 let chan = open_process_out cmd in
1185 descr_of_out_channel chan, chan
1187 let do_disconnect (_, chan) =
1188 match close_process_out chan with
1189 | WEXITED 0 -> () (* OK *)
1190 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
1191 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
1192 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
1195 (* XXX This is using the hostname derived from network configuration
1196 * above. We might want to ask the user to choose.
1198 let hostname = safe_name (gethostname ()) in
1200 let date = sprintf "%04d%02d%02d%02d%02d"
1201 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1202 "p2v-" ^ hostname ^ "-" ^ date in
1204 (* Work out what the image filenames will be at the remote end. *)
1205 let devices_to_send = List.map (
1206 fun (origin_dev, snapshot_dev, remote_dev) ->
1207 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1208 (origin_dev, snapshot_dev, remote_dev, remote_name)
1209 ) devices_to_send in
1211 (* Write a configuration file. Not sure if this is any better than
1212 * just 'sprintf-ing' bits of XML text together, but at least we will
1213 * always get well-formed XML.
1215 * XXX For some of the stuff here we really should do a
1216 * virConnectGetCapabilities call to the remote host first.
1218 * XXX There is a case for using virt-install to generate this XML.
1219 * When we start to incorporate libvirt access & storage API this
1220 * needs to be rethought.
1222 let conf_filename = basename ^ ".conf" in
1225 match state.architecture with
1226 | Some UnknownArch | None -> system_architecture
1227 | Some arch -> arch in
1229 match state.memory with
1230 | Some 0 | None -> system_memory
1231 | Some memory -> memory in
1233 match state.vcpus with
1234 | Some 0 | None -> system_nr_cpus
1237 match state.mac_address with
1240 List.map (sprintf "%02x") (
1241 List.map (fun _ -> Random.int 256) [0;0;0]
1243 String.concat ":" ("00"::"16"::"3e"::random)
1244 | Some mac -> mac in
1247 (* Shortcut to make "<name>value</name>". *)
1248 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1249 (* ... and the _other_ sort of leaf (god I hate XML). *)
1250 let tleaf name attribs = Xml.Element (name, attribs, []) in
1252 (* Standard stuff for every domain. *)
1253 let name = leaf "name" hostname in
1254 let memory = leaf "memory" (string_of_int (memory * 1024)) in
1255 let vcpu = leaf "vcpu" (string_of_int vcpus) in
1257 (* Top-level stuff which differs for each HV type (isn't this supposed
1258 * to be portable ...)
1261 match state.hypervisor with
1263 [Xml.Element ("os", [],
1265 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1266 tleaf "boot" ["dev", "hd"]]);
1267 Xml.Element ("features", [],
1271 tleaf "clock" ["sync", "localtime"]]
1273 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1274 tleaf "clock" ["sync", "localtime"]]
1276 [Xml.Element ("os", [],
1277 [Xml.Element ("type",
1279 string_of_architecture architecture;
1281 [Xml.PCData "hvm"]);
1282 tleaf "boot" ["dev", "hd"]])]
1286 (* <devices> section. *)
1289 match state.hypervisor with
1291 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1293 [leaf "emulator" "/usr/bin/qemu"]
1295 [leaf "emulator" "/usr/bin/qemu-kvm"]
1299 Xml.Element ("interface", ["type", "user"],
1300 [tleaf "mac" ["address", mac_address]]) in
1301 (* XXX should have an option for Xen bridging:
1303 "interface", ["type","bridge"],
1304 [tleaf "source" ["bridge","xenbr0"];
1305 tleaf "mac" ["address",mac_address];
1306 tleaf "script" ["path","vif-bridge"]])*)
1307 let graphics = tleaf "graphics" ["type", "vnc"] in
1309 let disks = List.map (
1310 fun (_, _, remote_dev, remote_name) ->
1312 "disk", ["type", "file";
1314 [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1315 tleaf "target" ["dev", remote_dev]]
1317 ) devices_to_send in
1321 emulator @ interface :: graphics :: disks
1324 (* Put it all together in <domain type='foo'>. *)
1327 (match state.hypervisor with
1328 | Some Xen -> ["type", "xen"]
1329 | Some QEMU -> ["type", "qemu"]
1330 | Some KVM -> ["type", "kvm"]
1332 name :: memory :: vcpu :: extras @ [devices]
1335 (* Convert XML configuration file to a string, then send it to the
1339 let xml = Xml.to_string_fmt xml in
1342 match state.hypervisor with
1343 | Some Xen | None -> ""
1344 | Some QEMU | Some KVM -> " -c qemu:///system" in
1345 let xml = sprintf "\
1347 This is a libvirt configuration file.
1349 To start the domain, do:
1352 -->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in
1354 let xml_len = String.length xml in
1355 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1357 let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1358 (* In OCaml this actually loops calling write(2) *)
1359 ignore (write sock xml 0 xml_len);
1360 do_disconnect conn in
1362 (* Send the device snapshots to the remote host. *)
1363 (* XXX This code should be made more robust against both network
1364 * errors and local I/O errors. Also should allow the user several
1365 * attempts to connect, or let them go back to the dialog stage.
1368 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1369 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1372 try List.assoc origin_dev all_block_devices
1373 with Not_found -> assert false (* internal error *) in
1375 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1376 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1378 (* Open the snapshot device. *)
1379 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1382 let (sock,_) as conn = do_connect remote_name size in
1384 (* Copy the data. *)
1385 let bufsize = 1024 * 1024 in
1386 let buffer = String.create bufsize in
1387 let start = gettimeofday () in
1389 let rec copy bytes_sent last_printed_at =
1390 let n = read fd buffer 0 bufsize in
1392 ignore (write sock buffer 0 n);
1394 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1395 let last_printed_at =
1396 let now = gettimeofday () in
1397 (* Print progress once per second. *)
1398 if now -. last_printed_at > 1. then (
1399 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1400 let secs_elapsed = now -. start in
1401 printf "%.0f%%" (100. *. elapsed);
1402 (* After 60 seconds has elapsed, start printing estimates. *)
1403 if secs_elapsed >= 60. then (
1404 let remaining = 1. -. elapsed in
1405 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1406 if secs_remaining > 120. then
1407 printf " (about %.0f minutes remaining) "
1408 (secs_remaining /. 60.)
1410 printf " (about %.0f seconds remaining) "
1416 else last_printed_at in
1418 copy bytes_sent last_printed_at
1427 (* Clean up and reboot. *)
1429 msgbox "virt-p2v completed"
1430 (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."
1431 remote_directory conf_filename)
1440 eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
1443 (* Make sure that exceptions from 'main' get printed out on stdout
1444 * as well as stderr, since stderr is probably redirected to the
1445 * logfile, and so not visible to the user.
1447 let handle_exn f arg =
1449 with exn -> print_endline (Printexc.to_string exn); raise exn
1451 (* Test harness for the Makefile. The Makefile invokes this script as
1452 * 'virt-p2v --test' just to check it compiles. When it is running
1453 * from the actual live CD, there is a single parameter which is the
1454 * tty name (so usually 'virt-p2v tty1').
1457 match Array.to_list Sys.argv with
1458 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1459 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1460 | [ _; ttyname ] -> (* Run main with ttyname. *)
1461 handle_exn main (Some ttyname)
1462 | [ _ ] -> (* Interactive - no ttyname. *)
1463 handle_exn main None
1466 (* This file must end with a newline *)