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 static_network_config : static_network_config option;
43 devices_to_send : string list option;
44 root_filesystem : partition option;
45 hypervisor : hypervisor option;
46 architecture : architecture option;
47 memory : int option; vcpus : int option;
48 mac_address : string option;
49 compression : bool option;
55 and partition = Part of string * string (* eg. "hda", "1" *)
56 | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
57 and hypervisor = Xen | QEMU | KVM
58 and architecture = I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
59 | OtherArch of string | UnknownArch
60 and static_network_config = string * string * string * string * string
61 (* interface, address, netmask, gateway, nameserver *)
63 (*----------------------------------------------------------------------*)
64 (* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
66 * If left as they are, then this will create a generic virt-p2v script
67 * which asks the user for each question. If you set the defaults here
68 * then you will get a custom virt-p2v which is partially or even fully
69 * automated and won't ask the user any questions.
71 * Note that 'None' means 'no default' (ie. ask the user) whereas
72 * 'Some foo' means use 'foo' as the answer.
75 (* If greeting is true, wait for keypress after boot and during
76 * final verification. Set to 'false' for less interactions.
80 (* These are now documented in the man page virt-p2v(1).
81 * 'None' means ask the user.
82 * After changing them, run './virt-p2v --test' to check syntax.
86 remote_directory = None;
87 remote_username = None;
88 devices_to_send = None;
89 root_filesystem = None;
91 static_network_config = None;
99 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
100 (*----------------------------------------------------------------------*)
102 (* General helper functions. *)
104 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
105 let xs = List.sort ~cmp xs in
106 let rec loop = function
107 | [] -> [] | [x] -> [x]
108 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
109 | x :: xs -> x :: loop xs
113 let input_all_lines chan =
114 let lines = ref [] in
116 while true do lines := input_line chan :: !lines done; []
118 End_of_file -> List.rev !lines
120 let dev_of_partition = function
121 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
122 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
124 let string_of_architecture = function
131 | SPARC64 -> "sparc64"
132 | OtherArch arch -> arch
135 type dialog_status = Yes of string list | No | Help | Back | Error
137 type ask_result = Next of state | Prev | Ask_again
139 type nature = LinuxSwap
140 | LinuxRoot of architecture * linux_distro
141 | WindowsRoot (* Windows C: *)
142 | LinuxBoot (* Linux /boot *)
143 | NotRoot (* mountable, but not / or /boot *)
145 and linux_distro = RHEL of int * int
147 | Debian of int * int
150 let rec string_of_nature = function
151 | LinuxSwap -> "Linux swap"
152 | LinuxRoot (architecture, distro) ->
153 string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
154 | WindowsRoot -> "Windows root"
155 | LinuxBoot -> "Linux /boot"
156 | NotRoot -> "Mountable non-root"
157 | UnknownNature -> "Unknown"
158 and string_of_linux_distro = function
159 | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
160 | Fedora v -> sprintf "Fedora %d" v
161 | Debian (a,b) -> sprintf "Debian %d.%d" a b
162 | OtherLinux -> "Linux"
166 * Each function takes some common parameters (eg. ~title) and some
167 * dialog-specific parameters.
169 * Returns the exit status (Yes lines | No | Help | Back | Error).
171 let msgbox, yesno, inputbox, radiolist, checklist, form =
172 (* Internal function to actually run the "dialog" shell command. *)
173 let run_dialog cparams params =
174 let params = cparams @ params in
175 eprintf "dialog %s\n%!"
176 (String.concat " " (List.map (sprintf "%S") params));
178 (* 'dialog' writes its output/result to stderr, so we need to take
179 * special steps to capture that - in other words, manual pipe/fork.
181 let rfd, wfd = pipe () in
183 | 0 -> (* child, runs dialog *)
185 dup2 wfd stderr; (* capture stderr to pipe *)
186 execvp "dialog" (Array.of_list ("dialog" :: params))
187 | pid -> (* parent *)
189 let chan = in_channel_of_descr rfd in
190 let result = input_all_lines chan in
192 eprintf "dialog result: %S\n%!" (String.concat "\n" result);
193 match snd (wait ()) with
194 | WEXITED 0 -> Yes result (* something selected / entered *)
195 | WEXITED 1 -> No (* cancel / no button *)
196 | WEXITED 2 -> Help (* help pressed *)
197 | WEXITED 3 -> Back (* back button *)
198 | WEXITED _ -> Error (* error or Esc *)
199 | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
200 | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
203 (* Handle the common parameters. Note Continuation Passing Style. *)
206 ?(backbutton=true) ?(backbutton_label="Back")
208 let params = ["--title"; title] in
209 let params = if not cancel then "--nocancel" :: params else params in
212 "--extra-button" :: "--extra-label" :: backbutton_label :: params
217 (* Message box and yes/no box. *)
220 fun cparams text height width ->
222 [ "--msgbox"; text; string_of_int height; string_of_int width ]
226 fun cparams text height width ->
228 [ "--yesno"; text; string_of_int height; string_of_int width ]
231 (* Simple input box. *)
234 fun cparams text height width default ->
236 [ "--inputbox"; text; string_of_int height; string_of_int width;
240 (* Radio list and check list. *)
243 fun cparams text height width listheight items ->
244 let items = List.map (
246 | tag, item, true -> [ tag; item; "on" ]
247 | tag, item, false -> [ tag; item; "off" ]
249 let items = List.concat items in
250 let items = "--single-quoted" ::
251 "--radiolist" :: text ::
252 string_of_int height :: string_of_int width ::
253 string_of_int listheight :: items in
254 run_dialog cparams items
258 fun cparams text height width listheight items ->
259 let items = List.map (
261 | tag, item, true -> [ tag; item; "on" ]
262 | tag, item, false -> [ tag; item; "off" ]
264 let items = List.concat items in
265 let items = "--separate-output" ::
266 "--checklist" :: text ::
267 string_of_int height :: string_of_int width ::
268 string_of_int listheight :: items in
269 run_dialog cparams items
275 fun cparams text height width formheight items ->
276 let items = List.map (
277 fun (label, y, x, item, y', x', flen, ilen) ->
278 [ label; string_of_int y; string_of_int x; item;
279 string_of_int y'; string_of_int x';
280 string_of_int flen; string_of_int ilen ]
282 let items = List.concat items in
283 let items = "--form" :: text ::
284 string_of_int height :: string_of_int width ::
285 string_of_int formheight :: items in
286 run_dialog cparams items
289 msgbox, yesno, inputbox, radiolist, checklist, form
291 (* Print failure dialog and exit. *)
292 let fail_dialog text =
293 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
294 ignore (msgbox "Error" text 17 50);
297 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
298 let quote = Filename.quote
300 (* Run a shell command and check it returns 0. *)
302 eprintf "sh: %s\n%!" cmd;
303 if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
306 eprintf "shfailok: %s\n%!" cmd;
307 ignore (Sys.command cmd)
309 let shwithstatus cmd =
310 eprintf "shwithstatus: %s\n%!" cmd;
313 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
315 eprintf "shget: %s\n%!" cmd;
316 let chan = open_process_in cmd in
317 let lines = input_all_lines chan in
318 match close_process_in chan with
319 | WEXITED 0 -> Some lines (* command succeeded *)
320 | WEXITED _ -> None (* command failed *)
321 | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
322 | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
324 (* Start an interactive shell. Need to juggle file descriptors a bit
325 * because bash write PS1 to stderr (currently directed to the logfile).
329 | 0 -> (* child, runs bash *)
332 (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
334 Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
336 | _ -> (* parent, waits *)
337 eprintf "waiting for subshell to exit\n%!";
340 (* Some true if is dir/file, Some false if not, None if not found. *)
342 try Some ((stat path).st_kind = S_DIR)
343 with Unix_error (ENOENT, "stat", _) -> None
345 try Some ((stat path).st_kind = S_REG)
346 with Unix_error (ENOENT, "stat", _) -> None
348 (* Useful regular expression. *)
349 let whitespace = Pcre.regexp "[ \t]+"
351 (* Generate a predictable safe name containing only letters, numbers
352 * and underscores. If passed a string with no letters or numbers,
353 * generates "_1", "_2", etc.
358 fun () -> incr i; "_" ^ string_of_int !i
361 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
362 let name = String.copy name in
363 let have_safe = ref false in
364 for i = 0 to String.length name - 1 do
365 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
367 if !have_safe then name else next_anon ()
369 type block_device = string * int64 (* "hda" & size in bytes *)
371 (* Parse the output of 'lvs' to get list of LV names, sizes,
372 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
375 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
379 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
383 let lines = List.map (Pcre.split ~rex:whitespace) lines in
386 | [vg; lv; pvs; lvsize]
387 | [_; vg; lv; pvs; lvsize] ->
388 let pvs = String.nsplit pvs "," in
389 let pvs = List.filter_map (
392 let subs = Pcre.exec ~rex:devname pv in
393 Some (Pcre.get_substring subs 1)
396 eprintf "lvs: unexpected device name: %s\n%!" pv;
399 LV (vg, lv), pvs, lvsize
401 failwith ("lvs: unexpected output: " ^ String.concat "," line)
404 (* Get the partitions on a block device.
405 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
407 let get_partitions dev =
408 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
409 let devdir = "/sys/block/" ^ dev in
410 let parts = Sys.readdir devdir in
411 let parts = Array.to_list parts in
412 let parts = List.filter (
413 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
415 let parts = List.filter_map (
418 let subs = Pcre.exec ~rex part in
419 Some (Part (dev, Pcre.get_substring subs 1))
425 (* Generate snapshot device name from device name. *)
426 let snapshot_name dev =
427 "snap" ^ (safe_name dev)
429 (* Perform a device-mapper snapshot with ramdisk overlay. *)
431 let next_free_ram_disk =
433 fun () -> incr i; "/dev/ram" ^ string_of_int !i
435 fun origin_dev snapshot_dev ->
436 let ramdisk = next_free_ram_disk () in
438 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
439 let lines = shget cmd in
441 | Some (sectors::_) -> Int64.of_string sectors
443 fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
445 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
446 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
447 snapshot_dev sectors origin_dev);
448 (* Create the snapshot. *)
449 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
450 snapshot_dev sectors snapshot_dev ramdisk)
452 (* Try to perform automatic network configuration, assuming a Fedora or
453 * RHEL-like root filesystem mounted on /mnt/root.
455 let auto_network state =
456 (* Fedora gives an error if this file doesn't exist. *)
457 sh "touch /etc/resolv.conf";
459 (* NB. Lazy unmount is required because dhclient keeps its current
460 * directory open on /etc/sysconfig/network-scripts/
462 sh "mount -o bind /mnt/root/etc /etc";
463 let status = shwithstatus "/etc/init.d/network start" in
466 (* Try to ping the remote host to see if this worked. *)
467 shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
469 if state.greeting then (
470 printf "\n\nDid automatic network configuration work?\n";
471 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
473 let line = read_line () in
474 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
477 (* Non-interactive: return the status of /etc/init.d/network start. *)
480 (* Configure the network statically. *)
481 let static_network state =
482 match state.static_network_config with
483 | None -> false (* failed *)
484 | Some (interface, address, netmask, gateway, nameserver) ->
485 let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
487 do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
488 (quote interface) (quote address) (quote netmask));
489 do_cmd_or_exit (sprintf "route add default gw %s %s"
490 (quote gateway) (quote interface));
491 if nameserver <> "" then
492 do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
496 Exit -> false (* failed *)
498 let qemu_network () =
499 sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0";
500 sh "route add default gw 10.0.2.2 eth0";
501 sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"
503 (* Map local device names to remote devices names. At the moment we
504 * just change sd* to hd* (as device names appear under fullvirt). In
505 * future, lots of complex possibilities.
507 let remote_of_origin_dev =
508 let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
509 let devsd_subst = Pcre.subst "hd$1" in
511 Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
513 (* Rewrite /mnt/root/etc/fstab. *)
514 let rewrite_fstab state devices_to_send =
515 let filename = "/mnt/root/etc/fstab" in
516 if is_file filename = Some true then (
517 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
519 let chan = open_in filename in
520 let lines = input_all_lines chan in
522 let lines = List.map (Pcre.split ~rex:whitespace) lines in
523 let lines = List.map (
525 | dev :: rest when String.starts_with dev "/dev/" ->
526 let dev = String.sub dev 5 (String.length dev - 5) in
527 let dev = remote_of_origin_dev dev in
528 let dev = "/dev/" ^ dev in
533 let chan = open_out filename in
536 | [dev; mountpoint; fstype; options; freq; passno] ->
537 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
538 dev mountpoint fstype options freq passno
540 output_string chan (String.concat " " line);
541 output_char chan '\n'
546 let () = Random.self_init ()
548 let random_mac_address () =
550 List.map (sprintf "%02x") (
551 List.map (fun _ -> Random.int 256) [0;0;0]
553 String.concat ":" ("00"::"16"::"3e"::random)
556 let hex = "0123456789abcdef" in
558 let str = String.create 32 in
559 for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
562 (* Main entry point. *)
563 let rec main ttyname =
564 (* Running from an init script. We don't have much of a
565 * login environment, so set one up.
569 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
570 "/usr/bin"; "/bin"]);
571 putenv "HOME" "/root";
572 putenv "LOGNAME" "root";
574 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
577 (* Set up logging to /tmp/virt-p2v.log. *)
578 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
582 (* Log the start up time. *)
583 eprintf "\n\n**************************************************\n\n";
584 let tm = localtime (time ()) in
585 eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
586 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
588 (* Connect stdin/stdout to the tty. *)
592 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
596 printf "virt-p2v starting up ...\n%!";
598 (* Disable screen blanking on tty. *)
599 sh "setterm -blank 0";
601 (* Check that the environment is a sane-looking live CD. If not, bail. *)
602 if is_dir "/mnt/root" <> Some true then
604 "You should only run this script from the live CD or a USB key.";
606 printf "virt-p2v detecting hard drives (this may take some time) ...\n%!";
608 (* Search for all non-removable block devices. Do this early and bail
609 * if we can't find anything. This is a list of strings, like "hda".
611 let all_block_devices : block_device list =
612 let rex = Pcre.regexp "^[hs]d" in
613 let devices = Array.to_list (Sys.readdir "/sys/block") in
614 let devices = List.sort devices in
615 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
616 eprintf "all_block_devices: block devices: %s\n%!"
617 (String.concat "; " devices);
618 (* Run blockdev --getsize64 on each, and reject any where this fails
619 * (probably removable devices).
621 let devices = List.filter_map (
623 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
624 let lines = shget cmd in
626 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
627 | Some [] | None -> None
629 eprintf "all_block_devices: non-removable block devices: %s\n%!"
631 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
633 fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
636 (* Search for partitions and LVs (anything that could contain a
637 * filesystem directly). We refer to these generically as
640 let all_partitions : partition list =
643 let lvs = get_lvs () in
644 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
645 let pvs = List.concat pvs in
646 let pvs = sort_uniq pvs in
647 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
648 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
649 eprintf "all_partitions: LVs: %s\n%!"
650 (String.concat "; " (List.map dev_of_partition lvs));
653 (* Partitions (eg. "sda1", "sda2"). *)
655 let parts = List.map fst all_block_devices in
656 let parts = List.map get_partitions parts in
657 let parts = List.concat parts in
658 eprintf "all_partitions: all partitions: %s\n%!"
659 (String.concat "; " (List.map dev_of_partition parts));
661 (* Remove any partitions which are PVs. *)
662 let parts = List.filter (
664 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
665 | LV _ -> assert false
668 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
669 (String.concat "; " (List.map dev_of_partition parts));
671 (* Concatenate LVs & Parts *)
674 (* Try to determine the nature of each partition.
675 * Root? Swap? Architecture? etc.
677 let all_partitions : (partition * nature) list =
678 (* Output of 'file' command for Linux swap file. *)
679 let swap = Pcre.regexp "Linux.*swap.*file" in
680 (* Contents of /etc/redhat-release. *)
681 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
682 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
683 (* Contents of /etc/debian_version. *)
684 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
685 (* Output of 'file' on certain executables. *)
686 let i386 = Pcre.regexp ", Intel 80386," in
687 let x86_64 = Pcre.regexp ", x86-64," in
688 let itanic = Pcre.regexp ", IA-64," in
690 (* Examine the filesystem mounted on 'mnt' to determine the
691 * operating system, and, if Linux, the distro.
694 if is_dir (mnt ^ "/Windows") = Some true &&
695 is_file (mnt ^ "/autoexec.bat") = Some true then
697 else if is_dir (mnt ^ "/etc") = Some true &&
698 is_dir (mnt ^ "/sbin") = Some true &&
699 is_dir (mnt ^ "/var") = Some true then (
700 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
701 let chan = open_in (mnt ^ "/etc/redhat-release") in
702 let lines = input_all_lines chan in
706 | [] -> (* empty /etc/redhat-release ...? *)
707 LinuxRoot (UnknownArch, OtherLinux)
708 | line::_ -> (* try to detect OS from /etc/redhat-release *)
710 let subs = Pcre.exec ~rex:rhel line in
711 let major = int_of_string (Pcre.get_substring subs 1) in
713 try int_of_string (Pcre.get_substring subs 2)
714 with Not_found -> 0 in
715 LinuxRoot (UnknownArch, RHEL (major, minor))
717 Not_found | Failure "int_of_string" ->
719 let subs = Pcre.exec ~rex:fedora line in
720 let version = int_of_string (Pcre.get_substring subs 1) in
721 LinuxRoot (UnknownArch, Fedora version)
723 Not_found | Failure "int_of_string" ->
724 LinuxRoot (UnknownArch, OtherLinux)
726 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
727 let chan = open_in (mnt ^ "/etc/debian_version") in
728 let lines = input_all_lines chan in
732 | [] -> (* empty /etc/debian_version ...? *)
733 LinuxRoot (UnknownArch, OtherLinux)
734 | line::_ -> (* try to detect version from /etc/debian_version *)
736 let subs = Pcre.exec ~rex:debian line in
737 let major = int_of_string (Pcre.get_substring subs 1) in
738 let minor = int_of_string (Pcre.get_substring subs 2) in
739 LinuxRoot (UnknownArch, Debian (major, minor))
741 Not_found | Failure "int_of_string" ->
742 LinuxRoot (UnknownArch, OtherLinux)
745 LinuxRoot (UnknownArch, OtherLinux)
746 ) else if is_dir (mnt ^ "/grub") = Some true &&
747 is_file (mnt ^ "/grub/stage1") = Some true then (
750 NotRoot (* mountable, but not a root filesystem *)
753 (* Examine the Linux root filesystem mounted on 'mnt' to
754 * determine the architecture. We do this by looking at some
755 * well-known binaries that we expect to be there.
757 let detect_architecture mnt =
758 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
760 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
761 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
762 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
768 let dev = dev_of_partition part in (* Get /dev device. *)
771 (* Use 'file' command to detect if it is swap. *)
772 let cmd = "file -sbL " ^ quote dev in
774 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
776 (* Blindly try to mount the device. *)
777 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
778 match shwithstatus cmd with
780 let os = detect_os "/mnt/root" in
783 | LinuxRoot (UnknownArch, distro) ->
784 let architecture = detect_architecture "/mnt/root" in
785 LinuxRoot (architecture, distro)
787 sh "umount /mnt/root";
790 | _ -> UnknownNature (* not mountable *)
794 eprintf "partition detection: %s is %s\n%!"
795 dev (string_of_nature nature);
801 printf "virt-p2v finished detecting hard drives\n%!";
804 let ask_greeting state =
805 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);
809 let ask_hostname state =
811 inputbox "Remote host" "Remote host" 10 50
812 (Option.default "" state.remote_host)
814 | Yes [] -> Ask_again
815 | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
816 | No | Help | Error -> Ask_again
822 inputbox "Remote port" "Remote port" 10 50
823 (Option.default "22" state.remote_port)
825 | Yes ([]|""::_) -> Next { state with remote_port = Some "22" }
826 | Yes (port::_) -> Next { state with remote_port = Some port }
827 | No | Help | Error -> Ask_again
831 let ask_directory state =
832 let default_dir = "/var/lib/xen/images" in
834 inputbox "Remote directory" "Remote directory" 10 50
835 (Option.default default_dir state.remote_directory)
837 | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir }
838 | Yes (dir::_) -> Next { state with remote_directory = Some dir }
839 | No | Help | Error -> Ask_again
843 let ask_username state =
844 let default_username = "root" in
846 inputbox "Remote username" "Remote username for ssh access to server" 10 50
847 (Option.default default_username state.remote_username)
850 Next { state with remote_username = Some default_username }
851 | Yes (user::_) -> Next { state with remote_username = Some user }
852 | No | Help | Error -> Ask_again
856 let ask_network state =
858 radiolist "Network configuration" "Network configuration" 12 50 4 [
859 "auto", "Automatic configuration", state.network = Some Auto;
860 "ask", "Ask for fixed IP address and gateway",
861 state.network = Some Static;
862 "sh", "Configure from the shell", state.network = Some Shell;
863 "qemu", "QEMU user network (for developers only)",
864 state.network = Some QEMUUserNet
867 | Yes ("auto"::_) -> Next { state with network = Some Auto }
868 | Yes ("ask"::_) -> Next { state with network = Some Static }
869 | Yes ("sh"::_) -> Next { state with network = Some Shell }
870 | Yes ("qemu"::_) -> Next { state with network = Some QEMUUserNet }
871 | Yes _ | No | Help | Error -> Ask_again
875 let ask_static_network_config state =
876 let interface, address, netmask, gateway, nameserver =
877 match state.static_network_config with
878 | Some (a,b,c,d,e) -> a,b,c,d,e
879 | None -> "eth0","","","","" in
881 form "Static network configuration" "Static network configuration"
883 "Interface", 1, 0, interface, 1, 12, 8, 0;
884 "Address", 2, 0, address, 2, 12, 16, 0;
885 "Netmask", 3, 0, netmask, 3, 12, 16, 0;
886 "Gateway", 4, 0, gateway, 4, 12, 16, 0;
887 "Nameserver", 5, 0, nameserver, 5, 12, 16, 0;
890 | Yes (interface::address::netmask::gateway::nameserver::_) ->
892 static_network_config = Some (interface, address, netmask,
893 gateway, nameserver) }
894 | Yes _ | No | Help | Error -> Ask_again
898 let ask_devices state =
899 let selected_devices = Option.default [] state.devices_to_send in
900 let devices = List.map (
901 fun (dev, blksize) ->
903 sprintf "/dev/%s (%.3f GB)" dev
904 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
905 List.mem dev selected_devices)
906 ) all_block_devices in
908 checklist "Devices" "Pick devices to send" 15 50 8 devices
910 | Yes [] | No | Help | Error -> Ask_again
911 | Yes devices -> Next { state with devices_to_send = Some devices }
916 let parts = List.mapi (
917 fun i (part, nature) ->
920 | LinuxSwap -> " (Linux swap)"
921 | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
922 | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
923 | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
924 | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
925 | WindowsRoot -> " (Windows C:)"
926 | LinuxBoot -> " (Linux /boot)"
927 | NotRoot -> " (filesystem)"
928 | UnknownNature -> "" in
930 dev_of_partition part ^ descr,
931 Some part = state.root_filesystem)
934 radiolist "Root device"
935 "Pick partition containing the root (/) filesystem" 18 70 9
939 let (part, _) = List.nth all_partitions (int_of_string i) in
940 Next { state with root_filesystem = Some part }
941 | Yes [] | No | Help | Error -> Ask_again
945 let ask_hypervisor state =
947 radiolist "Hypervisor"
948 "Choose hypervisor / virtualization system"
950 "xen", "Xen", state.hypervisor = Some Xen;
951 "qemu", "QEMU", state.hypervisor = Some QEMU;
952 "kvm", "KVM", state.hypervisor = Some KVM;
953 "other", "Other", state.hypervisor = None
956 | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
957 | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
958 | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
959 | Yes _ -> Next { state with hypervisor = None }
960 | No | Help | Error -> Ask_again
964 let ask_architecture state =
966 radiolist "Architecture" "Machine architecture" 16 50 8 [
967 "i386", "i386 and up (32 bit)", state.architecture = Some I386;
968 "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
969 "ia64", "Itanium IA64", state.architecture = Some IA64;
970 "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
971 "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
972 "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
973 "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
974 "auto", "Auto-detect",
975 state.architecture = None || state.architecture = Some UnknownArch;
978 | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
979 | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
980 | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
981 | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
982 | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
983 | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
984 | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
985 | Yes _ -> Next { state with architecture = Some UnknownArch }
986 | No | Help | Error -> Ask_again
990 let ask_memory state =
992 inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
994 (Option.map_default string_of_int "" state.memory)
996 | Yes (""::_ | []) -> Next { state with memory = Some 0 }
998 let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
999 if mem < 0 || (mem > 0 && mem < 64) then Ask_again
1000 else Next { state with memory = Some mem }
1001 | No | Help | Error -> Ask_again
1005 let ask_vcpus state =
1007 inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
1009 (Option.map_default string_of_int "" state.vcpus)
1011 | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
1014 try int_of_string vcpus with Failure "int_of_string" -> -1 in
1015 if vcpus < 0 then Ask_again
1016 else Next { state with vcpus = Some vcpus }
1017 | No | Help | Error -> Ask_again
1021 let ask_mac_address state =
1023 inputbox "MAC address"
1024 "Network MAC address. Leave blank to use a random address." 10 50
1025 (Option.default "" state.mac_address)
1027 | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
1028 | Yes (mac :: _) -> Next { state with mac_address = Some mac }
1029 | No | Help | Error -> Ask_again
1033 let ask_compression state =
1035 radiolist "Network compression" "Enable network compression" 10 50 2 [
1036 "yes", "Yes, compress network traffic", state.compression <> Some false;
1037 "no", "No, don't compress", state.compression = Some false
1040 | Yes ("no"::_) -> Next { state with compression = Some false }
1041 | Yes _ -> Next { state with compression = Some true }
1042 | No | Help | Error -> Ask_again
1046 let ask_verify state =
1048 yesno "Verify and proceed"
1049 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
1062 (Option.default "" state.remote_host)
1063 (Option.default "" state.remote_port)
1064 (Option.default "" state.remote_directory)
1065 (match state.network with
1066 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
1067 | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net"
1069 (String.concat "," (Option.default [] state.devices_to_send))
1070 (Option.map_default dev_of_partition "" state.root_filesystem)
1071 (match state.hypervisor with
1072 | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
1073 | None -> "Other / not set")
1074 (match state.architecture with
1075 | Some UnknownArch -> "Auto-detect"
1076 | Some arch -> string_of_architecture arch | None -> "")
1077 (match state.memory with
1078 | Some 0 -> "Same as physical"
1079 | Some mem -> string_of_int mem ^ " MB" | None -> "")
1080 (match state.vcpus with
1081 | Some 0 -> "Same as physical"
1082 | Some vcpus -> string_of_int vcpus | None -> "")
1083 (match state.mac_address with
1084 | Some "" -> "Random" | Some mac -> mac | None -> "")
1085 (Option.default true state.compression)
1089 | Yes _ -> Next state
1091 | No | Help | Error -> Ask_again
1094 (* This is the list of dialogs, in order. The user can go forwards or
1095 * backwards through them.
1097 * The second parameter in each tuple is true if we need to skip
1098 * this dialog statically (info already supplied in 'defaults' above).
1100 * The third parameter in each tuple is a function that tests whether
1101 * this dialog should be skipped, given other parts of the current state.
1104 let dont_skip _ = false in
1106 ask_greeting, not defaults.greeting, dont_skip;
1107 ask_hostname, defaults.remote_host <> None, dont_skip;
1108 ask_port, defaults.remote_port <> None, dont_skip;
1109 ask_directory, defaults.remote_directory <> None, dont_skip;
1110 ask_username, defaults.remote_username <> None, dont_skip;
1111 ask_network, defaults.network <> None, dont_skip;
1112 ask_static_network_config,
1113 defaults.static_network_config <> None,
1114 (function { network = Some Static } -> false | _ -> true);
1115 ask_devices, defaults.devices_to_send <> None, dont_skip;
1116 ask_root, defaults.root_filesystem <> None, dont_skip;
1117 ask_hypervisor, defaults.hypervisor <> None, dont_skip;
1118 ask_architecture, defaults.architecture <> None, dont_skip;
1119 ask_memory, defaults.memory <> None, dont_skip;
1120 ask_vcpus, defaults.vcpus <> None, dont_skip;
1121 ask_mac_address, defaults.mac_address <> None, dont_skip;
1122 ask_compression, defaults.compression <> None, dont_skip;
1123 ask_verify, not defaults.greeting, dont_skip;
1126 (* Loop through the dialogs until we reach the end. *)
1127 let rec loop ?(back=false) posn state =
1128 eprintf "dialog loop: posn = %d, back = %b\n%!" posn back;
1129 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
1130 else if posn < 0 then loop 0 state
1132 let dlg, skip_static, skip_dynamic = dlgs.(posn) in
1133 if skip_static || skip_dynamic state then
1134 (* Skip this dialog. *)
1135 loop ~back (if back then posn-1 else posn+1) state
1138 match dlg state with
1139 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
1140 | Ask_again -> loop posn state (* Repeat the question. *)
1141 | Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *)
1145 let state = loop 0 defaults in
1147 eprintf "finished dialog loop\n%!";
1149 (* Switch LVM config. *)
1151 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1152 sh "rm -f /etc/lvm/cache/.cache";
1153 sh "rm -f /etc/lvm.new/cache/.cache";
1155 (* Snapshot the block devices to send. *)
1156 let devices_to_send = Option.get state.devices_to_send in
1157 let devices_to_send =
1160 let snapshot_dev = snapshot_name origin_dev in
1161 snapshot origin_dev snapshot_dev;
1162 (origin_dev, snapshot_dev)
1163 ) devices_to_send in
1165 (* Run kpartx on the snapshots. *)
1167 fun (origin, snapshot) ->
1168 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1171 (* Rescan for LVs. *)
1175 (* Mount the root filesystem under /mnt/root. *)
1176 let root_filesystem = Option.get state.root_filesystem in
1177 (match root_filesystem with
1178 | Part (dev, partnum) ->
1179 let dev = dev ^ partnum in
1180 let snapshot_dev = snapshot_name dev in
1181 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1184 (* The LV will be backed by a snapshot device, so just mount
1187 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1190 (* See if we can do network configuration. *)
1191 let network = Option.get state.network in
1194 printf "Network configuration.\n\n";
1195 printf "Please configure the network from this shell.\n\n";
1196 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1200 printf "Trying static network configuration.\n\n%!";
1201 if not (static_network state) then (
1202 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1203 printf "Please configure the network from this shell.\n\n";
1204 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1210 "Trying network auto-configuration from root filesystem ...\n\n%!";
1211 if not (auto_network state) then (
1212 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1213 printf "Please configure the network from this shell.\n\n";
1214 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1218 printf "Trying QEMU network configuration.\n\n%!";
1222 (* Work out what devices will be called at the remote end. *)
1223 let devices_to_send = List.map (
1224 fun (origin_dev, snapshot_dev) ->
1225 let remote_dev = remote_of_origin_dev origin_dev in
1226 (origin_dev, snapshot_dev, remote_dev)
1227 ) devices_to_send in
1229 (* Modify files on the root filesystem. *)
1230 rewrite_fstab state devices_to_send;
1231 (* XXX Other files to rewrite? *)
1233 (* Unmount the root filesystem and sync disks. *)
1234 sh "umount /mnt/root";
1235 sh "sync"; (* Ugh, should be in stdlib. *)
1237 (* Get architecture of root filesystem, detected previously. *)
1238 let system_architecture =
1240 (match List.assoc root_filesystem all_partitions with
1241 | LinuxRoot (arch, _) -> arch
1242 | _ -> raise Not_found
1246 (* None was detected before, so assume same as live CD. *)
1247 let arch = shget "uname -m" in
1249 | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
1250 | Some ("x86_64"::_) -> X86_64
1251 | Some ("ia64"::_) -> IA64
1252 | _ -> I386 (* probably wrong XXX *) in
1254 (* Autodetect system memory. *)
1256 let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
1258 | Some (mem::_) -> int_of_float (float_of_string mem)
1261 (* Autodetect system # pCPUs. *)
1262 let system_nr_cpus =
1264 shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
1266 | Some (cpus::_) -> int_of_string cpus
1269 let remote_host = Option.get state.remote_host in
1270 let remote_port = Option.get state.remote_port in
1271 let remote_directory = Option.get state.remote_directory in
1272 let remote_username = Option.get state.remote_username in
1274 (* Functions to connect and disconnect from the remote system. *)
1275 let do_connect remote_name _ =
1276 let cmd = sprintf "ssh%s -l %s -p %s %s \"cat > %s/%s\""
1277 (if state.compression = Some false then "" else " -C")
1278 (quote remote_username) (quote remote_port) (quote remote_host)
1279 (quote remote_directory) (quote remote_name) in
1280 eprintf "connect: %s\n%!" cmd;
1281 let chan = open_process_out cmd in
1282 descr_of_out_channel chan, chan
1284 let do_disconnect (_, chan) =
1285 match close_process_out chan with
1286 | WEXITED 0 -> () (* OK *)
1287 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
1288 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
1289 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
1292 (* XXX This is using the hostname derived from network configuration
1293 * above. We might want to ask the user to choose.
1295 let hostname = safe_name (gethostname ()) in
1297 let date = sprintf "%04d%02d%02d%02d%02d"
1298 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1299 "p2v-" ^ hostname ^ "-" ^ date in
1301 (* Work out what the image filenames will be at the remote end. *)
1302 let devices_to_send = List.map (
1303 fun (origin_dev, snapshot_dev, remote_dev) ->
1304 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1305 (origin_dev, snapshot_dev, remote_dev, remote_name)
1306 ) devices_to_send in
1308 (* Write a configuration file. Not sure if this is any better than
1309 * just 'sprintf-ing' bits of XML text together, but at least we will
1310 * always get well-formed XML.
1312 * XXX For some of the stuff here we really should do a
1313 * virConnectGetCapabilities call to the remote host first.
1315 * XXX There is a case for using virt-install to generate this XML.
1316 * When we start to incorporate libvirt access & storage API this
1317 * needs to be rethought.
1319 let conf_filename = basename ^ ".conf" in
1322 match state.architecture with
1323 | Some UnknownArch | None -> system_architecture
1324 | Some arch -> arch in
1326 match state.memory with
1327 | Some 0 | None -> system_memory
1328 | Some memory -> memory in
1330 match state.vcpus with
1331 | Some 0 | None -> system_nr_cpus
1334 match state.mac_address with
1335 | Some "" | None -> random_mac_address ()
1336 | Some mac -> mac in
1339 (* Shortcut to make "<name>value</name>". *)
1340 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1341 (* ... and the _other_ sort of leaf (god I hate XML). *)
1342 let tleaf name attribs = Xml.Element (name, attribs, []) in
1344 (* Standard stuff for every domain. *)
1345 let name = leaf "name" hostname in
1346 let uuid = leaf "uuid" (random_uuid ()) in
1347 let maxmem = leaf "maxmem" (string_of_int (memory * 1024)) in
1348 let memory = leaf "memory" (string_of_int (memory * 1024)) in
1349 let vcpu = leaf "vcpu" (string_of_int vcpus) in
1351 (* Top-level stuff which differs for each HV type (isn't this supposed
1352 * to be portable ...)
1355 match state.hypervisor with
1357 [Xml.Element ("os", [],
1359 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1360 tleaf "boot" ["dev", "hd"]]);
1361 Xml.Element ("features", [],
1365 tleaf "clock" ["sync", "localtime"]]
1367 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1368 tleaf "clock" ["sync", "localtime"]]
1370 [Xml.Element ("os", [],
1371 [Xml.Element ("type",
1373 string_of_architecture architecture;
1375 [Xml.PCData "hvm"]);
1376 tleaf "boot" ["dev", "hd"]])]
1380 (* <devices> section. *)
1383 match state.hypervisor with
1385 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1387 [leaf "emulator" "/usr/bin/qemu"]
1389 [leaf "emulator" "/usr/bin/qemu-kvm"]
1393 Xml.Element ("interface", ["type", "user"],
1394 [tleaf "mac" ["address", mac_address]]) in
1395 (* XXX should have an option for Xen bridging:
1397 "interface", ["type","bridge"],
1398 [tleaf "source" ["bridge","xenbr0"];
1399 tleaf "mac" ["address",mac_address];
1400 tleaf "script" ["path","vif-bridge"]])*)
1401 let graphics = tleaf "graphics" ["type", "vnc"] in
1403 let disks = List.map (
1404 fun (_, _, remote_dev, remote_name) ->
1406 "disk", ["type", "file";
1408 [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1409 tleaf "target" ["dev", remote_dev]]
1411 ) devices_to_send in
1415 emulator @ interface :: graphics :: disks
1418 (* Put it all together in <domain type='foo'>. *)
1421 (match state.hypervisor with
1422 | Some Xen -> ["type", "xen"]
1423 | Some QEMU -> ["type", "qemu"]
1424 | Some KVM -> ["type", "kvm"]
1426 name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
1429 (* Convert XML configuration file to a string, then send it to the
1433 let xml = Xml.to_string_fmt xml in
1436 match state.hypervisor with
1437 | Some Xen | None -> ""
1438 | Some QEMU | Some KVM -> " -c qemu:///system" in
1439 let xml = sprintf "\
1441 This is a libvirt configuration file.
1443 To start the domain, do:
1446 -->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in
1448 let xml_len = String.length xml in
1449 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1451 let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1452 (* In OCaml this actually loops calling write(2) *)
1453 ignore (write sock xml 0 xml_len);
1454 do_disconnect conn in
1456 (* Send the device snapshots to the remote host. *)
1457 (* XXX This code should be made more robust against both network
1458 * errors and local I/O errors. Also should allow the user several
1459 * attempts to connect, or let them go back to the dialog stage.
1462 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1463 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1466 try List.assoc origin_dev all_block_devices
1467 with Not_found -> assert false (* internal error *) in
1469 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1470 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1472 (* Open the snapshot device. *)
1473 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1476 let (sock,_) as conn = do_connect remote_name size in
1478 (* Copy the data. *)
1479 let spinners = "|/-\\" (* "Oo" *) in
1480 let bufsize = 1024 * 1024 in
1481 let buffer = String.create bufsize in
1482 let start = gettimeofday () in
1484 let rec copy bytes_sent last_printed_at spinner =
1485 let n = read fd buffer 0 bufsize in
1487 let n' = write sock buffer 0 n in
1488 if n <> n' then assert false; (* never, according to the manual *)
1490 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1491 let last_printed_at, spinner =
1492 let now = gettimeofday () in
1493 (* Print progress every few seconds. *)
1494 if now -. last_printed_at > 2. then (
1495 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1496 let secs_elapsed = now -. start in
1497 printf "%.0f%% %c %.1f Mbps"
1498 (100. *. elapsed) spinners.[spinner]
1499 (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
1500 (* After 60 seconds has elapsed, start printing estimates. *)
1501 if secs_elapsed >= 60. then (
1502 let remaining = 1. -. elapsed in
1503 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1504 if secs_remaining > 120. then
1505 printf " (about %.0f minutes remaining)" (secs_remaining/.60.)
1507 printf " (about %.0f seconds remaining)"
1511 let spinner = (spinner + 1) mod String.length spinners in
1514 else last_printed_at, spinner in
1516 copy bytes_sent last_printed_at spinner
1520 printf "\n\n%!"; (* because of the messages printed above *)
1526 (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
1528 (* Clean up and reboot. *)
1530 msgbox "virt-p2v completed"
1531 (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."
1532 remote_directory conf_filename)
1541 eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
1544 (* Make sure that exceptions from 'main' get printed out on stdout
1545 * as well as stderr, since stderr is probably redirected to the
1546 * logfile, and so not visible to the user.
1548 let handle_exn f arg =
1550 with exn -> print_endline (Printexc.to_string exn); raise exn
1552 (* Test harness for the Makefile. The Makefile invokes this script as
1553 * 'virt-p2v --test' just to check it compiles. When it is running
1554 * from the actual live CD, there is a single parameter which is the
1555 * tty name (so usually 'virt-p2v tty1').
1558 match Array.to_list Sys.argv with
1559 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1560 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1561 | [ _; ttyname ] -> (* Run main with ttyname. *)
1562 handle_exn main (Some ttyname)
1563 | [ _ ] -> (* Interactive - no ttyname. *)
1564 handle_exn main None
1567 (* This file must end with a newline *)