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;
54 and partition = Part of string * string (* eg. "hda", "1" *)
55 | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
56 and hypervisor = Xen | QEMU | KVM
57 and architecture = I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
58 | OtherArch of string | UnknownArch
59 and static_network_config = string * string * string * string * string
60 (* interface, address, netmask, gateway, nameserver *)
62 (*----------------------------------------------------------------------*)
63 (* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
65 * If left as they are, then this will create a generic virt-p2v script
66 * which asks the user for each question. If you set the defaults here
67 * then you will get a custom virt-p2v which is partially or even fully
68 * automated and won't ask the user any questions.
70 * Note that 'None' means 'no default' (ie. ask the user) whereas
71 * 'Some foo' means use 'foo' as the answer.
74 (* If greeting is true, wait for keypress after boot and during
75 * final verification. Set to 'false' for less interactions.
79 (* These are now documented in the man page virt-p2v(1).
80 * 'None' means ask the user.
81 * After changing them, run './virt-p2v --test' to check syntax.
85 remote_directory = None;
86 remote_username = None;
87 devices_to_send = None;
88 root_filesystem = None;
90 static_network_config = None;
97 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
98 (*----------------------------------------------------------------------*)
100 (* General helper functions. *)
102 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
103 let xs = List.sort ~cmp xs in
104 let rec loop = function
105 | [] -> [] | [x] -> [x]
106 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
107 | x :: xs -> x :: loop xs
111 let input_all_lines chan =
112 let lines = ref [] in
114 while true do lines := input_line chan :: !lines done; []
116 End_of_file -> List.rev !lines
118 let dev_of_partition = function
119 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
120 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
122 let string_of_architecture = function
129 | SPARC64 -> "sparc64"
130 | OtherArch arch -> arch
133 type dialog_status = Yes of string list | No | Help | Back | Error
135 type ask_result = Next of state | Prev | Ask_again
137 type nature = LinuxSwap
138 | LinuxRoot of architecture * linux_distro
139 | WindowsRoot (* Windows C: *)
140 | LinuxBoot (* Linux /boot *)
141 | NotRoot (* mountable, but not / or /boot *)
143 and linux_distro = RHEL of int * int
145 | Debian of int * int
148 let rec string_of_nature = function
149 | LinuxSwap -> "Linux swap"
150 | LinuxRoot (architecture, distro) ->
151 string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
152 | WindowsRoot -> "Windows root"
153 | LinuxBoot -> "Linux /boot"
154 | NotRoot -> "Mountable non-root"
155 | UnknownNature -> "Unknown"
156 and string_of_linux_distro = function
157 | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
158 | Fedora v -> sprintf "Fedora %d" v
159 | Debian (a,b) -> sprintf "Debian %d.%d" a b
160 | OtherLinux -> "Linux"
164 * Each function takes some common parameters (eg. ~title) and some
165 * dialog-specific parameters.
167 * Returns the exit status (Yes lines | No | Help | Back | Error).
169 let msgbox, yesno, inputbox, radiolist, checklist, form =
170 (* Internal function to actually run the "dialog" shell command. *)
171 let run_dialog cparams params =
172 let params = cparams @ params in
173 eprintf "dialog %s\n%!"
174 (String.concat " " (List.map (sprintf "%S") params));
176 (* 'dialog' writes its output/result to stderr, so we need to take
177 * special steps to capture that - in other words, manual pipe/fork.
179 let rfd, wfd = pipe () in
181 | 0 -> (* child, runs dialog *)
183 dup2 wfd stderr; (* capture stderr to pipe *)
184 execvp "dialog" (Array.of_list ("dialog" :: params))
185 | pid -> (* parent *)
187 let chan = in_channel_of_descr rfd in
188 let result = input_all_lines chan in
190 eprintf "dialog result: %S\n%!" (String.concat "\n" result);
191 match snd (wait ()) with
192 | WEXITED 0 -> Yes result (* something selected / entered *)
193 | WEXITED 1 -> No (* cancel / no button *)
194 | WEXITED 2 -> Help (* help pressed *)
195 | WEXITED 3 -> Back (* back button *)
196 | WEXITED _ -> Error (* error or Esc *)
197 | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
198 | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
201 (* Handle the common parameters. Note Continuation Passing Style. *)
202 let with_common cont ?(cancel=false) ?(backbutton=true) title =
203 let params = ["--title"; title] in
204 let params = if not cancel then "--nocancel" :: params else params in
206 if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
211 (* Message box and yes/no box. *)
214 fun cparams text height width ->
216 [ "--msgbox"; text; string_of_int height; string_of_int width ]
220 fun cparams text height width ->
222 [ "--yesno"; text; string_of_int height; string_of_int width ]
225 (* Simple input box. *)
228 fun cparams text height width default ->
230 [ "--inputbox"; text; string_of_int height; string_of_int width;
234 (* Radio list and check list. *)
237 fun cparams text height width listheight items ->
238 let items = List.map (
240 | tag, item, true -> [ tag; item; "on" ]
241 | tag, item, false -> [ tag; item; "off" ]
243 let items = List.concat items in
244 let items = "--single-quoted" ::
245 "--radiolist" :: text ::
246 string_of_int height :: string_of_int width ::
247 string_of_int listheight :: items in
248 run_dialog cparams items
252 fun cparams text height width listheight items ->
253 let items = List.map (
255 | tag, item, true -> [ tag; item; "on" ]
256 | tag, item, false -> [ tag; item; "off" ]
258 let items = List.concat items in
259 let items = "--separate-output" ::
260 "--checklist" :: text ::
261 string_of_int height :: string_of_int width ::
262 string_of_int listheight :: items in
263 run_dialog cparams items
269 fun cparams text height width formheight items ->
270 let items = List.map (
271 fun (label, y, x, item, y', x', flen, ilen) ->
272 [ label; string_of_int y; string_of_int x; item;
273 string_of_int y'; string_of_int x';
274 string_of_int flen; string_of_int ilen ]
276 let items = List.concat items in
277 let items = "--form" :: text ::
278 string_of_int height :: string_of_int width ::
279 string_of_int formheight :: items in
280 run_dialog cparams items
283 msgbox, yesno, inputbox, radiolist, checklist, form
285 (* Print failure dialog and exit. *)
286 let fail_dialog text =
287 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
288 ignore (msgbox "Error" text 17 50);
291 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
292 let quote = Filename.quote
294 (* Run a shell command and check it returns 0. *)
296 eprintf "sh: %s\n%!" cmd;
297 if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
300 eprintf "shfailok: %s\n%!" cmd;
301 ignore (Sys.command cmd)
303 let shwithstatus cmd =
304 eprintf "shwithstatus: %s\n%!" cmd;
307 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
309 eprintf "shget: %s\n%!" cmd;
310 let chan = open_process_in cmd in
311 let lines = input_all_lines chan in
312 match close_process_in chan with
313 | WEXITED 0 -> Some lines (* command succeeded *)
314 | WEXITED _ -> None (* command failed *)
315 | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
316 | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
318 (* Start an interactive shell. Need to juggle file descriptors a bit
319 * because bash write PS1 to stderr (currently directed to the logfile).
323 | 0 -> (* child, runs bash *)
326 (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
328 Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
330 | _ -> (* parent, waits *)
331 eprintf "waiting for subshell to exit\n%!";
334 (* Some true if is dir/file, Some false if not, None if not found. *)
336 try Some ((stat path).st_kind = S_DIR)
337 with Unix_error (ENOENT, "stat", _) -> None
339 try Some ((stat path).st_kind = S_REG)
340 with Unix_error (ENOENT, "stat", _) -> None
342 (* Useful regular expression. *)
343 let whitespace = Pcre.regexp "[ \t]+"
345 (* Generate a predictable safe name containing only letters, numbers
346 * and underscores. If passed a string with no letters or numbers,
347 * generates "_1", "_2", etc.
352 fun () -> incr i; "_" ^ string_of_int !i
355 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
356 let name = String.copy name in
357 let have_safe = ref false in
358 for i = 0 to String.length name - 1 do
359 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
361 if !have_safe then name else next_anon ()
363 type block_device = string * int64 (* "hda" & size in bytes *)
365 (* Parse the output of 'lvs' to get list of LV names, sizes,
366 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
369 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
373 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
377 let lines = List.map (Pcre.split ~rex:whitespace) lines in
380 | [vg; lv; pvs; lvsize]
381 | [_; vg; lv; pvs; lvsize] ->
382 let pvs = String.nsplit pvs "," in
383 let pvs = List.filter_map (
386 let subs = Pcre.exec ~rex:devname pv in
387 Some (Pcre.get_substring subs 1)
390 eprintf "lvs: unexpected device name: %s\n%!" pv;
393 LV (vg, lv), pvs, lvsize
395 failwith ("lvs: unexpected output: " ^ String.concat "," line)
398 (* Get the partitions on a block device.
399 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
401 let get_partitions dev =
402 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
403 let devdir = "/sys/block/" ^ dev in
404 let parts = Sys.readdir devdir in
405 let parts = Array.to_list parts in
406 let parts = List.filter (
407 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
409 let parts = List.filter_map (
412 let subs = Pcre.exec ~rex part in
413 Some (Part (dev, Pcre.get_substring subs 1))
419 (* Generate snapshot device name from device name. *)
420 let snapshot_name dev =
421 "snap" ^ (safe_name dev)
423 (* Perform a device-mapper snapshot with ramdisk overlay. *)
425 let next_free_ram_disk =
427 fun () -> incr i; "/dev/ram" ^ string_of_int !i
429 fun origin_dev snapshot_dev ->
430 let ramdisk = next_free_ram_disk () in
432 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
433 let lines = shget cmd in
435 | Some (sectors::_) -> Int64.of_string sectors
437 fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
439 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
440 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
441 snapshot_dev sectors origin_dev);
442 (* Create the snapshot. *)
443 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
444 snapshot_dev sectors snapshot_dev ramdisk)
446 (* Try to perform automatic network configuration, assuming a Fedora or
447 * RHEL-like root filesystem mounted on /mnt/root.
449 let auto_network state =
450 (* Fedora gives an error if this file doesn't exist. *)
451 sh "touch /etc/resolv.conf";
454 (* We can run /mnt/root/etc/init.d/network in a chroot environment,
455 * however this won't work directly because the architecture of the
456 * binaries under /mnt/root (eg. /mnt/root/sbin/ip) might not match
457 * the architecture of the live CD kernel. In particular, a 32 bit
458 * live CD cannot run 64 bit binaries. So we also have to bind-mount
459 * the live CD's /bin, /sbin, /lib etc. over the equivalents in
463 if is_dir dir = Some true then
464 sh ("mount -o bind " ^ quote dir ^ " " ^ quote ("/mnt/root" ^ dir))
467 if is_dir dir = Some true then sh ("umount -l " ^ quote ("/mnt/root" ^ dir))
470 "/bin"; "/sbin"; "/lib"; "/lib64";
471 "/usr/bin"; "/usr/sbin"; "/usr/lib"; "/usr/lib64";
475 let status = shwithstatus "chroot /mnt/root /etc/init.d/network start" in
476 List.iter unbind dirs;
479 (* Simpler way to do the above.
480 * NB. Lazy unmount is required because dhclient keeps its current
481 * directory open on /etc/sysconfig/network-scripts/
483 sh "mount -o bind /mnt/root/etc /etc";
484 let status = shwithstatus "/etc/init.d/network start" in
487 (* Try to ping the remote host to see if this worked. *)
488 shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
490 if state.greeting then (
491 printf "\n\nDid automatic network configuration work?\n";
492 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
494 let line = read_line () in
495 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
498 (* Non-interactive: return the status of /etc/init.d/network start. *)
501 (* Configure the network statically. *)
502 let static_network state =
503 match state.static_network_config with
504 | None -> false (* failed *)
505 | Some (interface, address, netmask, gateway, nameserver) ->
506 let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
508 do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
509 (quote interface) (quote address) (quote netmask));
510 do_cmd_or_exit (sprintf "route add default gw %s %s"
511 (quote gateway) (quote interface));
512 if nameserver <> "" then
513 do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
517 Exit -> false (* failed *)
519 let qemu_network () =
520 sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0";
521 sh "route add default gw 10.0.2.2 eth0";
522 sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"
524 (* Map local device names to remote devices names. At the moment we
525 * just change sd* to hd* (as device names appear under fullvirt). In
526 * future, lots of complex possibilities.
528 let remote_of_origin_dev =
529 let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
530 let devsd_subst = Pcre.subst "hd$1" in
532 Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
534 (* Rewrite /mnt/root/etc/fstab. *)
535 let rewrite_fstab state devices_to_send =
536 let filename = "/mnt/root/etc/fstab" in
537 if is_file filename = Some true then (
538 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
540 let chan = open_in filename in
541 let lines = input_all_lines chan in
543 let lines = List.map (Pcre.split ~rex:whitespace) lines in
544 let lines = List.map (
546 | dev :: rest when String.starts_with dev "/dev/" ->
547 let dev = String.sub dev 5 (String.length dev - 5) in
548 let dev = remote_of_origin_dev dev in
549 let dev = "/dev/" ^ dev in
554 let chan = open_out filename in
557 | [dev; mountpoint; fstype; options; freq; passno] ->
558 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
559 dev mountpoint fstype options freq passno
561 output_string chan (String.concat " " line)
566 let () = Random.self_init ()
568 let random_mac_address () =
570 List.map (sprintf "%02x") (
571 List.map (fun _ -> Random.int 256) [0;0;0]
573 String.concat ":" ("00"::"16"::"3e"::random)
576 let hex = "0123456789abcdef" in
578 let str = String.create 32 in
579 for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
582 (* Main entry point. *)
583 let rec main ttyname =
584 (* Running from an init script. We don't have much of a
585 * login environment, so set one up.
589 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
590 "/usr/bin"; "/bin"]);
591 putenv "HOME" "/root";
592 putenv "LOGNAME" "root";
594 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
597 (* Set up logging to /tmp/virt-p2v.log. *)
598 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
602 (* Log the start up time. *)
603 eprintf "\n\n**************************************************\n\n";
604 let tm = localtime (time ()) in
605 eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
606 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
608 (* Connect stdin/stdout to the tty. *)
612 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
616 printf "virt-p2v starting up ...\n%!";
618 (* Disable screen blanking on tty. *)
619 sh "setterm -blank 0";
621 (* Check that the environment is a sane-looking live CD. If not, bail. *)
622 if is_dir "/mnt/root" <> Some true then
624 "You should only run this script from the live CD or a USB key.";
626 printf "virt-p2v detecting hard drives (this may take some time) ...\n%!";
628 (* Search for all non-removable block devices. Do this early and bail
629 * if we can't find anything. This is a list of strings, like "hda".
631 let all_block_devices : block_device list =
632 let rex = Pcre.regexp "^[hs]d" in
633 let devices = Array.to_list (Sys.readdir "/sys/block") in
634 let devices = List.sort devices in
635 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
636 eprintf "all_block_devices: block devices: %s\n%!"
637 (String.concat "; " devices);
638 (* Run blockdev --getsize64 on each, and reject any where this fails
639 * (probably removable devices).
641 let devices = List.filter_map (
643 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
644 let lines = shget cmd in
646 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
647 | Some [] | None -> None
649 eprintf "all_block_devices: non-removable block devices: %s\n%!"
651 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
653 fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
656 (* Search for partitions and LVs (anything that could contain a
657 * filesystem directly). We refer to these generically as
660 let all_partitions : partition list =
663 let lvs = get_lvs () in
664 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
665 let pvs = List.concat pvs in
666 let pvs = sort_uniq pvs in
667 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
668 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
669 eprintf "all_partitions: LVs: %s\n%!"
670 (String.concat "; " (List.map dev_of_partition lvs));
673 (* Partitions (eg. "sda1", "sda2"). *)
675 let parts = List.map fst all_block_devices in
676 let parts = List.map get_partitions parts in
677 let parts = List.concat parts in
678 eprintf "all_partitions: all partitions: %s\n%!"
679 (String.concat "; " (List.map dev_of_partition parts));
681 (* Remove any partitions which are PVs. *)
682 let parts = List.filter (
684 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
685 | LV _ -> assert false
688 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
689 (String.concat "; " (List.map dev_of_partition parts));
691 (* Concatenate LVs & Parts *)
694 (* Try to determine the nature of each partition.
695 * Root? Swap? Architecture? etc.
697 let all_partitions : (partition * nature) list =
698 (* Output of 'file' command for Linux swap file. *)
699 let swap = Pcre.regexp "Linux.*swap.*file" in
700 (* Contents of /etc/redhat-release. *)
701 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
702 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
703 (* Contents of /etc/debian_version. *)
704 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
705 (* Output of 'file' on certain executables. *)
706 let i386 = Pcre.regexp ", Intel 80386," in
707 let x86_64 = Pcre.regexp ", x86-64," in
708 let itanic = Pcre.regexp ", IA-64," in
710 (* Examine the filesystem mounted on 'mnt' to determine the
711 * operating system, and, if Linux, the distro.
714 if is_dir (mnt ^ "/Windows") = Some true &&
715 is_file (mnt ^ "/autoexec.bat") = Some true then
717 else if is_dir (mnt ^ "/etc") = Some true &&
718 is_dir (mnt ^ "/sbin") = Some true &&
719 is_dir (mnt ^ "/var") = Some true then (
720 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
721 let chan = open_in (mnt ^ "/etc/redhat-release") in
722 let lines = input_all_lines chan in
726 | [] -> (* empty /etc/redhat-release ...? *)
727 LinuxRoot (UnknownArch, OtherLinux)
728 | line::_ -> (* try to detect OS from /etc/redhat-release *)
730 let subs = Pcre.exec ~rex:rhel line in
731 let major = int_of_string (Pcre.get_substring subs 1) in
733 try int_of_string (Pcre.get_substring subs 2)
734 with Not_found -> 0 in
735 LinuxRoot (UnknownArch, RHEL (major, minor))
737 Not_found | Failure "int_of_string" ->
739 let subs = Pcre.exec ~rex:fedora line in
740 let version = int_of_string (Pcre.get_substring subs 1) in
741 LinuxRoot (UnknownArch, Fedora version)
743 Not_found | Failure "int_of_string" ->
744 LinuxRoot (UnknownArch, OtherLinux)
746 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
747 let chan = open_in (mnt ^ "/etc/debian_version") in
748 let lines = input_all_lines chan in
752 | [] -> (* empty /etc/debian_version ...? *)
753 LinuxRoot (UnknownArch, OtherLinux)
754 | line::_ -> (* try to detect version from /etc/debian_version *)
756 let subs = Pcre.exec ~rex:debian line in
757 let major = int_of_string (Pcre.get_substring subs 1) in
758 let minor = int_of_string (Pcre.get_substring subs 2) in
759 LinuxRoot (UnknownArch, Debian (major, minor))
761 Not_found | Failure "int_of_string" ->
762 LinuxRoot (UnknownArch, OtherLinux)
765 LinuxRoot (UnknownArch, OtherLinux)
766 ) else if is_dir (mnt ^ "/grub") = Some true &&
767 is_file (mnt ^ "/grub/stage1") = Some true then (
770 NotRoot (* mountable, but not a root filesystem *)
773 (* Examine the Linux root filesystem mounted on 'mnt' to
774 * determine the architecture. We do this by looking at some
775 * well-known binaries that we expect to be there.
777 let detect_architecture mnt =
778 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
780 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
781 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
782 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
788 let dev = dev_of_partition part in (* Get /dev device. *)
791 (* Use 'file' command to detect if it is swap. *)
792 let cmd = "file -sbL " ^ quote dev in
794 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
796 (* Blindly try to mount the device. *)
797 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
798 match shwithstatus cmd with
800 let os = detect_os "/mnt/root" in
803 | LinuxRoot (UnknownArch, distro) ->
804 let architecture = detect_architecture "/mnt/root" in
805 LinuxRoot (architecture, distro)
807 sh "umount /mnt/root";
810 | _ -> UnknownNature (* not mountable *)
814 eprintf "partition detection: %s is %s\n%!"
815 dev (string_of_nature nature);
821 printf "virt-p2v finished detecting hard drives\n%!";
824 let ask_greeting state =
825 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);
829 let ask_hostname state =
831 inputbox "Remote host" "Remote host" 10 50
832 (Option.default "" state.remote_host)
834 | Yes [] -> Ask_again
835 | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
836 | No | Help | Error -> Ask_again
842 inputbox "Remote port" "Remote port" 10 50
843 (Option.default "22" state.remote_port)
845 | Yes ([]|""::_) -> Next { state with remote_port = Some "22" }
846 | Yes (port::_) -> Next { state with remote_port = Some port }
847 | No | Help | Error -> Ask_again
851 let ask_directory state =
852 let default_dir = "/var/lib/xen/images" in
854 inputbox "Remote directory" "Remote directory" 10 50
855 (Option.default default_dir state.remote_directory)
857 | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir }
858 | Yes (dir::_) -> Next { state with remote_directory = Some dir }
859 | No | Help | Error -> Ask_again
863 let ask_username state =
864 let default_username = "root" in
866 inputbox "Remote username" "Remote username for ssh access to server" 10 50
867 (Option.default default_username state.remote_username)
870 Next { state with remote_username = Some default_username }
871 | Yes (user::_) -> Next { state with remote_username = Some user }
872 | No | Help | Error -> Ask_again
876 let ask_network state =
878 radiolist "Network configuration" "Network configuration" 12 50 4 [
879 "auto", "Automatic configuration", state.network = Some Auto;
880 "ask", "Ask for fixed IP address and gateway",
881 state.network = Some Static;
882 "sh", "Configure from the shell", state.network = Some Shell;
883 "qemu", "QEMU user network (for developers only)",
884 state.network = Some QEMUUserNet
887 | Yes ("auto"::_) -> Next { state with network = Some Auto }
888 | Yes ("ask"::_) -> Next { state with network = Some Static }
889 | Yes ("sh"::_) -> Next { state with network = Some Shell }
890 | Yes ("qemu"::_) -> Next { state with network = Some QEMUUserNet }
891 | Yes _ | No | Help | Error -> Ask_again
895 let ask_static_network_config state =
896 let interface, address, netmask, gateway, nameserver =
897 match state.static_network_config with
898 | Some (a,b,c,d,e) -> a,b,c,d,e
899 | None -> "eth0","","","","" in
901 form "Static network configuration" "Static network configuration"
903 "Interface", 1, 0, interface, 1, 12, 8, 0;
904 "Address", 2, 0, address, 2, 12, 16, 0;
905 "Netmask", 3, 0, netmask, 3, 12, 16, 0;
906 "Gateway", 4, 0, gateway, 4, 12, 16, 0;
907 "Nameserver", 5, 0, nameserver, 5, 12, 16, 0;
910 | Yes (interface::address::netmask::gateway::nameserver::_) ->
912 static_network_config = Some (interface, address, netmask,
913 gateway, nameserver) }
914 | Yes _ | No | Help | Error -> Ask_again
918 let ask_devices state =
919 let selected_devices = Option.default [] state.devices_to_send in
920 let devices = List.map (
921 fun (dev, blksize) ->
923 sprintf "/dev/%s (%.3f GB)" dev
924 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
925 List.mem dev selected_devices)
926 ) all_block_devices in
928 checklist "Devices" "Pick devices to send" 15 50 8 devices
930 | Yes [] | No | Help | Error -> Ask_again
931 | Yes devices -> Next { state with devices_to_send = Some devices }
936 let parts = List.mapi (
937 fun i (part, nature) ->
940 | LinuxSwap -> " (Linux swap)"
941 | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
942 | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
943 | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
944 | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
945 | WindowsRoot -> " (Windows C:)"
946 | LinuxBoot -> " (Linux /boot)"
947 | NotRoot -> " (filesystem)"
948 | UnknownNature -> "" in
950 dev_of_partition part ^ descr,
951 Some part = state.root_filesystem)
954 radiolist "Root device"
955 "Pick partition containing the root (/) filesystem" 18 70 9
959 let (part, _) = List.nth all_partitions (int_of_string i) in
960 Next { state with root_filesystem = Some part }
961 | Yes [] | No | Help | Error -> Ask_again
965 let ask_hypervisor state =
967 radiolist "Hypervisor"
968 "Choose hypervisor / virtualization system"
970 "xen", "Xen", state.hypervisor = Some Xen;
971 "qemu", "QEMU", state.hypervisor = Some QEMU;
972 "kvm", "KVM", state.hypervisor = Some KVM;
973 "other", "Other", state.hypervisor = None
976 | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
977 | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
978 | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
979 | Yes _ -> Next { state with hypervisor = None }
980 | No | Help | Error -> Ask_again
984 let ask_architecture state =
986 radiolist "Architecture" "Machine architecture" 16 50 8 [
987 "i386", "i386 and up (32 bit)", state.architecture = Some I386;
988 "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
989 "ia64", "Itanium IA64", state.architecture = Some IA64;
990 "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
991 "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
992 "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
993 "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
994 "auto", "Auto-detect",
995 state.architecture = None || state.architecture = Some UnknownArch;
998 | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
999 | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
1000 | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
1001 | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
1002 | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
1003 | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
1004 | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
1005 | Yes _ -> Next { state with architecture = Some UnknownArch }
1006 | No | Help | Error -> Ask_again
1010 let ask_memory state =
1012 inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
1014 (Option.map_default string_of_int "" state.memory)
1016 | Yes (""::_ | []) -> Next { state with memory = Some 0 }
1018 let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
1019 if mem < 0 || (mem > 0 && mem < 64) then Ask_again
1020 else Next { state with memory = Some mem }
1021 | No | Help | Error -> Ask_again
1025 let ask_vcpus state =
1027 inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
1029 (Option.map_default string_of_int "" state.vcpus)
1031 | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
1034 try int_of_string vcpus with Failure "int_of_string" -> -1 in
1035 if vcpus < 0 then Ask_again
1036 else Next { state with vcpus = Some vcpus }
1037 | No | Help | Error -> Ask_again
1041 let ask_mac_address state =
1043 inputbox "MAC address"
1044 "Network MAC address. Leave blank to use a random address." 10 50
1045 (Option.default "" state.mac_address)
1047 | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
1048 | Yes (mac :: _) -> Next { state with mac_address = Some mac }
1049 | No | Help | Error -> Ask_again
1053 let ask_verify state =
1055 yesno "Verify and proceed"
1056 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
1068 (Option.default "" state.remote_host)
1069 (Option.default "" state.remote_port)
1070 (Option.default "" state.remote_directory)
1071 (match state.network with
1072 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
1073 | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net"
1075 (String.concat "," (Option.default [] state.devices_to_send))
1076 (Option.map_default dev_of_partition "" state.root_filesystem)
1077 (match state.hypervisor with
1078 | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
1079 | None -> "Other / not set")
1080 (match state.architecture with
1081 | Some UnknownArch -> "Auto-detect"
1082 | Some arch -> string_of_architecture arch | None -> "")
1083 (match state.memory with
1084 | Some 0 -> "Same as physical"
1085 | Some mem -> string_of_int mem ^ " MB" | None -> "")
1086 (match state.vcpus with
1087 | Some 0 -> "Same as physical"
1088 | Some vcpus -> string_of_int vcpus | None -> "")
1089 (match state.mac_address with
1090 | Some "" -> "Random" | Some mac -> mac | None -> "")
1094 | Yes _ -> Next state
1096 | No | Help | Error -> Ask_again
1099 (* This is the list of dialogs, in order. The user can go forwards or
1100 * backwards through them.
1102 * The second parameter in each tuple is true if we need to skip
1103 * this dialog statically (info already supplied in 'defaults' above).
1105 * The third parameter in each tuple is a function that tests whether
1106 * this dialog should be skipped, given other parts of the current state.
1109 let dont_skip _ = false in
1111 ask_greeting, not defaults.greeting, dont_skip;
1112 ask_hostname, defaults.remote_host <> None, dont_skip;
1113 ask_port, defaults.remote_port <> None, dont_skip;
1114 ask_directory, defaults.remote_directory <> None, dont_skip;
1115 ask_username, defaults.remote_username <> None, dont_skip;
1116 ask_network, defaults.network <> None, dont_skip;
1117 ask_static_network_config,
1118 defaults.static_network_config <> None,
1119 (function { network = Some Static } -> false | _ -> true);
1120 ask_devices, defaults.devices_to_send <> None, dont_skip;
1121 ask_root, defaults.root_filesystem <> None, dont_skip;
1122 ask_hypervisor, defaults.hypervisor <> None, dont_skip;
1123 ask_architecture, defaults.architecture <> None, dont_skip;
1124 ask_memory, defaults.memory <> None, dont_skip;
1125 ask_vcpus, defaults.vcpus <> None, dont_skip;
1126 ask_mac_address, defaults.mac_address <> None, dont_skip;
1127 ask_verify, not defaults.greeting, dont_skip;
1130 (* Loop through the dialogs until we reach the end. *)
1131 let rec loop ?(back=false) posn state =
1132 eprintf "dialog loop: posn = %d, back = %b\n%!" posn back;
1133 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
1134 else if posn < 0 then loop 0 state
1136 let dlg, skip_static, skip_dynamic = dlgs.(posn) in
1137 if skip_static || skip_dynamic state then
1138 (* Skip this dialog. *)
1139 loop ~back (if back then posn-1 else posn+1) state
1142 match dlg state with
1143 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
1144 | Ask_again -> loop posn state (* Repeat the question. *)
1145 | Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *)
1149 let state = loop 0 defaults in
1151 eprintf "finished dialog loop\n%!";
1153 (* Switch LVM config. *)
1155 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1156 sh "rm -f /etc/lvm/cache/.cache";
1157 sh "rm -f /etc/lvm.new/cache/.cache";
1159 (* Snapshot the block devices to send. *)
1160 let devices_to_send = Option.get state.devices_to_send in
1161 let devices_to_send =
1164 let snapshot_dev = snapshot_name origin_dev in
1165 snapshot origin_dev snapshot_dev;
1166 (origin_dev, snapshot_dev)
1167 ) devices_to_send in
1169 (* Run kpartx on the snapshots. *)
1171 fun (origin, snapshot) ->
1172 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1175 (* Rescan for LVs. *)
1179 (* Mount the root filesystem under /mnt/root. *)
1180 let root_filesystem = Option.get state.root_filesystem in
1181 (match root_filesystem with
1182 | Part (dev, partnum) ->
1183 let dev = dev ^ partnum in
1184 let snapshot_dev = snapshot_name dev in
1185 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1188 (* The LV will be backed by a snapshot device, so just mount
1191 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1194 (* See if we can do network configuration. *)
1195 let network = Option.get state.network in
1198 printf "Network configuration.\n\n";
1199 printf "Please configure the network from this shell.\n\n";
1200 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1204 printf "Trying static network configuration.\n\n%!";
1205 if not (static_network state) then (
1206 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1207 printf "Please configure the network from this shell.\n\n";
1208 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1214 "Trying network auto-configuration from root filesystem ...\n\n%!";
1215 if not (auto_network state) then (
1216 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1217 printf "Please configure the network from this shell.\n\n";
1218 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1222 printf "Trying QEMU network configuration.\n\n%!";
1226 (* Work out what devices will be called at the remote end. *)
1227 let devices_to_send = List.map (
1228 fun (origin_dev, snapshot_dev) ->
1229 let remote_dev = remote_of_origin_dev origin_dev in
1230 (origin_dev, snapshot_dev, remote_dev)
1231 ) devices_to_send in
1233 (* Modify files on the root filesystem. *)
1234 rewrite_fstab state devices_to_send;
1235 (* XXX Other files to rewrite? *)
1237 (* Unmount the root filesystem and sync disks. *)
1238 sh "umount /mnt/root";
1239 sh "sync"; (* Ugh, should be in stdlib. *)
1241 (* Get architecture of root filesystem, detected previously. *)
1242 let system_architecture =
1244 (match List.assoc root_filesystem all_partitions with
1245 | LinuxRoot (arch, _) -> arch
1246 | _ -> raise Not_found
1250 (* None was detected before, so assume same as live CD. *)
1251 let arch = shget "uname -m" in
1253 | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
1254 | Some ("x86_64"::_) -> X86_64
1255 | Some ("ia64"::_) -> IA64
1256 | _ -> I386 (* probably wrong XXX *) in
1258 (* Autodetect system memory. *)
1260 let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
1262 | Some (mem::_) -> int_of_float (float_of_string mem)
1265 (* Autodetect system # pCPUs. *)
1266 let system_nr_cpus =
1268 shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
1270 | Some (cpus::_) -> int_of_string cpus
1273 let remote_host = Option.get state.remote_host in
1274 let remote_port = Option.get state.remote_port in
1275 let remote_directory = Option.get state.remote_directory in
1276 let remote_username = Option.get state.remote_username in
1278 (* Functions to connect and disconnect from the remote system. *)
1279 let do_connect remote_name _ =
1280 let cmd = sprintf "ssh -C -l %s -p %s %s \"cat > %s/%s\""
1281 (quote remote_username) (quote remote_port) (quote remote_host)
1282 (quote remote_directory) (quote remote_name) in
1283 eprintf "connect: %s\n%!" cmd;
1284 let chan = open_process_out cmd in
1285 descr_of_out_channel chan, chan
1287 let do_disconnect (_, chan) =
1288 match close_process_out chan with
1289 | WEXITED 0 -> () (* OK *)
1290 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
1291 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
1292 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
1295 (* XXX This is using the hostname derived from network configuration
1296 * above. We might want to ask the user to choose.
1298 let hostname = safe_name (gethostname ()) in
1300 let date = sprintf "%04d%02d%02d%02d%02d"
1301 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1302 "p2v-" ^ hostname ^ "-" ^ date in
1304 (* Work out what the image filenames will be at the remote end. *)
1305 let devices_to_send = List.map (
1306 fun (origin_dev, snapshot_dev, remote_dev) ->
1307 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1308 (origin_dev, snapshot_dev, remote_dev, remote_name)
1309 ) devices_to_send in
1311 (* Write a configuration file. Not sure if this is any better than
1312 * just 'sprintf-ing' bits of XML text together, but at least we will
1313 * always get well-formed XML.
1315 * XXX For some of the stuff here we really should do a
1316 * virConnectGetCapabilities call to the remote host first.
1318 * XXX There is a case for using virt-install to generate this XML.
1319 * When we start to incorporate libvirt access & storage API this
1320 * needs to be rethought.
1322 let conf_filename = basename ^ ".conf" in
1325 match state.architecture with
1326 | Some UnknownArch | None -> system_architecture
1327 | Some arch -> arch in
1329 match state.memory with
1330 | Some 0 | None -> system_memory
1331 | Some memory -> memory in
1333 match state.vcpus with
1334 | Some 0 | None -> system_nr_cpus
1337 match state.mac_address with
1338 | Some "" | None -> random_mac_address ()
1339 | Some mac -> mac in
1342 (* Shortcut to make "<name>value</name>". *)
1343 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1344 (* ... and the _other_ sort of leaf (god I hate XML). *)
1345 let tleaf name attribs = Xml.Element (name, attribs, []) in
1347 (* Standard stuff for every domain. *)
1348 let name = leaf "name" hostname in
1349 let uuid = leaf "uuid" (random_uuid ()) in
1350 let maxmem = leaf "maxmem" (string_of_int (memory * 1024)) in
1351 let memory = leaf "memory" (string_of_int (memory * 1024)) in
1352 let vcpu = leaf "vcpu" (string_of_int vcpus) in
1354 (* Top-level stuff which differs for each HV type (isn't this supposed
1355 * to be portable ...)
1358 match state.hypervisor with
1360 [Xml.Element ("os", [],
1362 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1363 tleaf "boot" ["dev", "hd"]]);
1364 Xml.Element ("features", [],
1368 tleaf "clock" ["sync", "localtime"]]
1370 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1371 tleaf "clock" ["sync", "localtime"]]
1373 [Xml.Element ("os", [],
1374 [Xml.Element ("type",
1376 string_of_architecture architecture;
1378 [Xml.PCData "hvm"]);
1379 tleaf "boot" ["dev", "hd"]])]
1383 (* <devices> section. *)
1386 match state.hypervisor with
1388 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1390 [leaf "emulator" "/usr/bin/qemu"]
1392 [leaf "emulator" "/usr/bin/qemu-kvm"]
1396 Xml.Element ("interface", ["type", "user"],
1397 [tleaf "mac" ["address", mac_address]]) in
1398 (* XXX should have an option for Xen bridging:
1400 "interface", ["type","bridge"],
1401 [tleaf "source" ["bridge","xenbr0"];
1402 tleaf "mac" ["address",mac_address];
1403 tleaf "script" ["path","vif-bridge"]])*)
1404 let graphics = tleaf "graphics" ["type", "vnc"] in
1406 let disks = List.map (
1407 fun (_, _, remote_dev, remote_name) ->
1409 "disk", ["type", "file";
1411 [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1412 tleaf "target" ["dev", remote_dev]]
1414 ) devices_to_send in
1418 emulator @ interface :: graphics :: disks
1421 (* Put it all together in <domain type='foo'>. *)
1424 (match state.hypervisor with
1425 | Some Xen -> ["type", "xen"]
1426 | Some QEMU -> ["type", "qemu"]
1427 | Some KVM -> ["type", "kvm"]
1429 name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
1432 (* Convert XML configuration file to a string, then send it to the
1436 let xml = Xml.to_string_fmt xml in
1439 match state.hypervisor with
1440 | Some Xen | None -> ""
1441 | Some QEMU | Some KVM -> " -c qemu:///system" in
1442 let xml = sprintf "\
1444 This is a libvirt configuration file.
1446 To start the domain, do:
1449 -->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in
1451 let xml_len = String.length xml in
1452 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1454 let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1455 (* In OCaml this actually loops calling write(2) *)
1456 ignore (write sock xml 0 xml_len);
1457 do_disconnect conn in
1459 (* Send the device snapshots to the remote host. *)
1460 (* XXX This code should be made more robust against both network
1461 * errors and local I/O errors. Also should allow the user several
1462 * attempts to connect, or let them go back to the dialog stage.
1465 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1466 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1469 try List.assoc origin_dev all_block_devices
1470 with Not_found -> assert false (* internal error *) in
1472 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1473 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1475 (* Open the snapshot device. *)
1476 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1479 let (sock,_) as conn = do_connect remote_name size in
1481 (* Copy the data. *)
1482 let bufsize = 1024 * 1024 in
1483 let buffer = String.create bufsize in
1484 let start = gettimeofday () in
1486 let rec copy bytes_sent last_printed_at =
1487 let n = read fd buffer 0 bufsize in
1489 ignore (write sock buffer 0 n);
1491 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1492 let last_printed_at =
1493 let now = gettimeofday () in
1494 (* Print progress once per second. *)
1495 if now -. last_printed_at > 1. then (
1496 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1497 let secs_elapsed = now -. start in
1498 printf "%.0f%%" (100. *. elapsed);
1499 (* After 60 seconds has elapsed, start printing estimates. *)
1500 if secs_elapsed >= 60. then (
1501 let remaining = 1. -. elapsed in
1502 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1503 if secs_remaining > 120. then
1504 printf " (about %.0f minutes remaining) "
1505 (secs_remaining /. 60.)
1507 printf " (about %.0f seconds remaining) "
1513 else last_printed_at in
1515 copy bytes_sent last_printed_at
1524 (* Clean up and reboot. *)
1526 msgbox "virt-p2v completed"
1527 (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."
1528 remote_directory conf_filename)
1537 eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
1540 (* Make sure that exceptions from 'main' get printed out on stdout
1541 * as well as stderr, since stderr is probably redirected to the
1542 * logfile, and so not visible to the user.
1544 let handle_exn f arg =
1546 with exn -> print_endline (Printexc.to_string exn); raise exn
1548 (* Test harness for the Makefile. The Makefile invokes this script as
1549 * 'virt-p2v --test' just to check it compiles. When it is running
1550 * from the actual live CD, there is a single parameter which is the
1551 * tty name (so usually 'virt-p2v tty1').
1554 match Array.to_list Sys.argv with
1555 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1556 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1557 | [ _; ttyname ] -> (* Run main with ttyname. *)
1558 handle_exn main (Some ttyname)
1559 | [ _ ] -> (* Interactive - no ttyname. *)
1560 handle_exn main None
1563 (* This file must end with a newline *)