1 #!/usr/bin/ocamlrun /usr/bin/ocaml
7 #directory "+xml-light";;
8 #load "xml-light.cma";;
10 (* virt-p2v.ml is a script which performs a physical to
11 * virtual conversion of local disks.
13 * Copyright (C) 2007-2008 Red Hat Inc.
14 * Written by Richard W.M. Jones <rjones@redhat.com>
16 * This program is free software; you can redistribute it and/or modify
17 * it under the terms of the GNU General Public License as published by
18 * the Free Software Foundation; either version 2 of the License, or
19 * (at your option) any later version.
21 * This program is distributed in the hope that it will be useful,
22 * but WITHOUT ANY WARRANTY; without even the implied warranty of
23 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 * GNU General Public License for more details.
26 * You should have received a copy of the GNU General Public License
27 * along with this program; if not, write to the Free Software
28 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
36 type state = { greeting : bool;
37 remote_host : string option; remote_port : string option;
38 remote_directory : string option;
39 remote_username : string option;
40 network : network option;
41 devices_to_send : string list option;
42 root_filesystem : partition option;
43 hypervisor : hypervisor option;
44 architecture : architecture option;
45 memory : int option; vcpus : int option;
46 mac_address : string option;
48 and network = Auto | Shell
49 and partition = Part of string * string (* eg. "hda", "1" *)
50 | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
51 and hypervisor = Xen | QEMU | KVM
52 and architecture = I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
53 | OtherArch of string | UnknownArch
55 (*----------------------------------------------------------------------*)
56 (* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
58 * If left as they are, then this will create a generic virt-p2v script
59 * which asks the user for each question. If you set the defaults here
60 * then you will get a custom virt-p2v which is partially or even fully
61 * automated and won't ask the user any questions.
63 * Note that 'None' means 'no default' (ie. ask the user) whereas
64 * 'Some foo' means use 'foo' as the answer.
67 (* If greeting is true, wait for keypress after boot and during
68 * final verification. Set to 'false' for less interactions.
72 (* Remote host and port. Set to 'Some "host"' and 'Some "port"',
78 (* Remote directory. Set to 'Some "path"' to set up a
79 * directory path, else ask the user.
81 remote_directory = None;
83 (* Remote username for ssh. Set to 'Some "username"', or None to
86 remote_username = None;
88 (* List of devices to send. Set to 'Some ["sda"; "sdb"]' for
89 * example to select /dev/sda and /dev/sdb.
91 devices_to_send = None;
93 (* The root filesystem containing /etc/fstab. Set to
94 * 'Some (Part ("sda", "3"))' or 'Some (LV ("VolGroup00", "LogVol00"))'
95 * for example, else ask user.
97 root_filesystem = None;
99 (* Network configuration: Set to 'Some Auto' (try to set it up
100 * automatically, or 'Some Shell' (give the user a shell).
104 (* Hypervisor: Set to 'Some Xen', 'Some QEMU' or 'Some KVM'. *)
107 (* Architecture: Set to 'Some X86_64' (or another architecture).
108 * If set to 'Some UnknownArch' then we try to autodetect the
109 * right architecture.
113 (* Memory: Set to 'Some nn' with nn in megabytes. If set to 'Some 0'
114 * then we use same amount of RAM as installed in the physical machine.
118 (* Virtual CPUs: Set to 'Some nn' where nn is the number of virtual CPUs.
119 * If set to 'Some 0' then we use the same as physical CPUs in the
124 (* MAC address: Set to 'Some "aa:bb:cc:dd:ee:ff"' where the string is
125 * the MAC address of the emulated network card. Set to 'Some ""' to
126 * choose a random MAC address.
130 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
131 (*----------------------------------------------------------------------*)
133 (* General helper functions. *)
135 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
136 let xs = List.sort ~cmp xs in
137 let rec loop = function
138 | [] -> [] | [x] -> [x]
139 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
140 | x :: xs -> x :: loop xs
144 let input_all_lines chan =
145 let lines = ref [] in
147 while true do lines := input_line chan :: !lines done; []
149 End_of_file -> List.rev !lines
151 let dev_of_partition = function
152 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
153 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
155 let string_of_architecture = function
162 | SPARC64 -> "sparc64"
163 | OtherArch arch -> arch
166 type dialog_status = Yes of string list | No | Help | Back | Error
168 type ask_result = Next of state | Prev | Ask_again
170 type nature = LinuxSwap
171 | LinuxRoot of architecture * linux_distro
172 | WindowsRoot (* Windows C: *)
173 | LinuxBoot (* Linux /boot *)
174 | NotRoot (* mountable, but not / or /boot *)
176 and linux_distro = RHEL of int * int
178 | Debian of int * int
181 let rec string_of_nature = function
182 | LinuxSwap -> "Linux swap"
183 | LinuxRoot (architecture, distro) ->
184 string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
185 | WindowsRoot -> "Windows root"
186 | LinuxBoot -> "Linux /boot"
187 | NotRoot -> "Mountable non-root"
188 | UnknownNature -> "Unknown"
189 and string_of_linux_distro = function
190 | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
191 | Fedora v -> sprintf "Fedora %d" v
192 | Debian (a,b) -> sprintf "Debian %d.%d" a b
193 | OtherLinux -> "Linux"
197 * Each function takes some common parameters (eg. ~title) and some
198 * dialog-specific parameters.
200 * Returns the exit status (Yes lines | No | Help | Back | Error).
202 let msgbox, yesno, inputbox, radiolist, checklist =
203 (* Internal function to actually run the "dialog" shell command. *)
204 let run_dialog cparams params =
205 let params = cparams @ params in
206 eprintf "dialog %s\n%!"
207 (String.concat " " (List.map (sprintf "%S") params));
209 (* 'dialog' writes its output/result to stderr, so we need to take
210 * special steps to capture that - in other words, manual pipe/fork.
212 let rfd, wfd = pipe () in
214 | 0 -> (* child, runs dialog *)
216 dup2 wfd stderr; (* capture stderr to pipe *)
217 execvp "dialog" (Array.of_list ("dialog" :: params))
218 | pid -> (* parent *)
220 let chan = in_channel_of_descr rfd in
221 let result = input_all_lines chan in
223 eprintf "dialog result: %S\n%!" (String.concat "\n" result);
224 match snd (wait ()) with
225 | WEXITED 0 -> Yes result (* something selected / entered *)
226 | WEXITED 1 -> No (* cancel / no button *)
227 | WEXITED 2 -> Help (* help pressed *)
228 | WEXITED 3 -> Back (* back button *)
229 | WEXITED _ -> Error (* error or Esc *)
230 | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
231 | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
234 (* Handle the common parameters. Note Continuation Passing Style. *)
235 let with_common cont ?(cancel=false) ?(backbutton=true) title =
236 let params = ["--title"; title] in
237 let params = if not cancel then "--nocancel" :: params else params in
239 if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
244 (* Message box and yes/no box. *)
247 fun cparams text height width ->
249 [ "--msgbox"; text; string_of_int height; string_of_int width ]
253 fun cparams text height width ->
255 [ "--yesno"; text; string_of_int height; string_of_int width ]
258 (* Simple input box. *)
261 fun cparams text height width default ->
263 [ "--inputbox"; text; string_of_int height; string_of_int width;
267 (* Radio list and check list. *)
270 fun cparams text height width listheight items ->
271 let items = List.map (
273 | tag, item, true -> [ tag; item; "on" ]
274 | tag, item, false -> [ tag; item; "off" ]
276 let items = List.concat items in
277 let items = "--single-quoted" ::
278 "--radiolist" :: text ::
279 string_of_int height :: string_of_int width ::
280 string_of_int listheight :: items in
281 run_dialog cparams items
285 fun cparams text height width listheight items ->
286 let items = List.map (
288 | tag, item, true -> [ tag; item; "on" ]
289 | tag, item, false -> [ tag; item; "off" ]
291 let items = List.concat items in
292 let items = "--separate-output" ::
293 "--checklist" :: text ::
294 string_of_int height :: string_of_int width ::
295 string_of_int listheight :: items in
296 run_dialog cparams items
299 msgbox, yesno, inputbox, radiolist, checklist
301 (* Print failure dialog and exit. *)
302 let fail_dialog text =
303 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
304 ignore (msgbox "Error" text 17 50);
307 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
308 let quote = Filename.quote
310 (* Run a shell command and check it returns 0. *)
312 eprintf "sh: %s\n%!" cmd;
313 if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
316 eprintf "shfailok: %s\n%!" cmd;
317 ignore (Sys.command cmd)
319 let shwithstatus cmd =
320 eprintf "shwithstatus: %s\n%!" cmd;
323 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
325 eprintf "shget: %s\n%!" cmd;
326 let chan = open_process_in cmd in
327 let lines = input_all_lines chan in
328 match close_process_in chan with
329 | WEXITED 0 -> Some lines (* command succeeded *)
330 | WEXITED _ -> None (* command failed *)
331 | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
332 | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
334 (* Start an interactive shell. Need to juggle file descriptors a bit
335 * because bash write PS1 to stderr (currently directed to the logfile).
339 | 0 -> (* child, runs bash *)
342 (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
344 Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
346 | _ -> (* parent, waits *)
347 eprintf "waiting for subshell to exit\n%!";
350 (* Some true if is dir/file, Some false if not, None if not found. *)
352 try Some ((stat path).st_kind = S_DIR)
353 with Unix_error (ENOENT, "stat", _) -> None
355 try Some ((stat path).st_kind = S_REG)
356 with Unix_error (ENOENT, "stat", _) -> None
358 (* Useful regular expression. *)
359 let whitespace = Pcre.regexp "[ \t]+"
361 (* Generate a predictable safe name containing only letters, numbers
362 * and underscores. If passed a string with no letters or numbers,
363 * generates "_1", "_2", etc.
368 fun () -> incr i; "_" ^ string_of_int !i
371 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
372 let name = String.copy name in
373 let have_safe = ref false in
374 for i = 0 to String.length name - 1 do
375 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
377 if !have_safe then name else next_anon ()
379 type block_device = string * int64 (* "hda" & size in bytes *)
381 (* Parse the output of 'lvs' to get list of LV names, sizes,
382 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
385 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
389 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
393 let lines = List.map (Pcre.split ~rex:whitespace) lines in
396 | [vg; lv; pvs; lvsize]
397 | [_; vg; lv; pvs; lvsize] ->
398 let pvs = String.nsplit pvs "," in
399 let pvs = List.filter_map (
402 let subs = Pcre.exec ~rex:devname pv in
403 Some (Pcre.get_substring subs 1)
406 eprintf "lvs: unexpected device name: %s\n%!" pv;
409 LV (vg, lv), pvs, lvsize
411 failwith ("lvs: unexpected output: " ^ String.concat "," line)
414 (* Get the partitions on a block device.
415 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
417 let get_partitions dev =
418 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
419 let devdir = "/sys/block/" ^ dev in
420 let parts = Sys.readdir devdir in
421 let parts = Array.to_list parts in
422 let parts = List.filter (
423 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
425 let parts = List.filter_map (
428 let subs = Pcre.exec ~rex part in
429 Some (Part (dev, Pcre.get_substring subs 1))
435 (* Generate snapshot device name from device name. *)
436 let snapshot_name dev =
437 "snap" ^ (safe_name dev)
439 (* Perform a device-mapper snapshot with ramdisk overlay. *)
441 let next_free_ram_disk =
443 fun () -> incr i; "/dev/ram" ^ string_of_int !i
445 fun origin_dev snapshot_dev ->
446 let ramdisk = next_free_ram_disk () in
448 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
449 let lines = shget cmd in
451 | Some (sectors::_) -> Int64.of_string sectors
453 fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
455 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
456 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
457 snapshot_dev sectors origin_dev);
458 (* Create the snapshot. *)
459 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
460 snapshot_dev sectors snapshot_dev ramdisk)
462 (* Try to perform automatic network configuration, assuming a Fedora or
463 * RHEL-like root filesystem mounted on /mnt/root.
465 let auto_network state =
466 (* Fedora gives an error if this file doesn't exist. *)
467 sh "touch /etc/resolv.conf";
470 (* We can run /mnt/root/etc/init.d/network in a chroot environment,
471 * however this won't work directly because the architecture of the
472 * binaries under /mnt/root (eg. /mnt/root/sbin/ip) might not match
473 * the architecture of the live CD kernel. In particular, a 32 bit
474 * live CD cannot run 64 bit binaries. So we also have to bind-mount
475 * the live CD's /bin, /sbin, /lib etc. over the equivalents in
479 if is_dir dir = Some true then
480 sh ("mount -o bind " ^ quote dir ^ " " ^ quote ("/mnt/root" ^ dir))
483 if is_dir dir = Some true then sh ("umount -l " ^ quote ("/mnt/root" ^ dir))
486 "/bin"; "/sbin"; "/lib"; "/lib64";
487 "/usr/bin"; "/usr/sbin"; "/usr/lib"; "/usr/lib64";
491 let status = shwithstatus "chroot /mnt/root /etc/init.d/network start" in
492 List.iter unbind dirs;
495 (* Simpler way to do the above.
496 * NB. Lazy unmount is required because dhclient keeps its current
497 * directory open on /etc/sysconfig/network-scripts/
499 sh "mount -o bind /mnt/root/etc /etc";
500 let status = shwithstatus "/etc/init.d/network start" in
503 (* Try to ping the remote host to see if this worked. *)
504 shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
506 if state.greeting then (
507 printf "\n\nDid automatic network configuration work?\n";
508 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
510 let line = read_line () in
511 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
514 (* Non-interactive: return the status of /etc/init.d/network start. *)
517 (* Map local device names to remote devices names. At the moment we
518 * just change sd* to hd* (as device names appear under fullvirt). In
519 * future, lots of complex possibilities.
521 let remote_of_origin_dev =
522 let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
523 let devsd_subst = Pcre.subst "hd$1" in
525 Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
527 (* Rewrite /mnt/root/etc/fstab. *)
528 let rewrite_fstab state devices_to_send =
529 let filename = "/mnt/root/etc/fstab" in
530 if is_file filename = Some true then (
531 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
533 let chan = open_in filename in
534 let lines = input_all_lines chan in
536 let lines = List.map (Pcre.split ~rex:whitespace) lines in
537 let lines = List.map (
539 | dev :: rest when String.starts_with dev "/dev/" ->
540 let dev = String.sub dev 5 (String.length dev - 5) in
541 let dev = remote_of_origin_dev dev in
542 let dev = "/dev/" ^ dev in
547 let chan = open_out filename in
550 | [dev; mountpoint; fstype; options; freq; passno] ->
551 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
552 dev mountpoint fstype options freq passno
554 output_string chan (String.concat " " line)
559 (* Main entry point. *)
560 let rec main ttyname =
561 (* Running from an init script. We don't have much of a
562 * login environment, so set one up.
566 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
567 "/usr/bin"; "/bin"]);
568 putenv "HOME" "/root";
569 putenv "LOGNAME" "root";
571 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
574 (* Set up logging to /tmp/virt-p2v.log. *)
575 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
579 (* Log the start up time. *)
580 eprintf "\n\n**************************************************\n\n";
581 let tm = localtime (time ()) in
582 eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
583 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
585 (* Connect stdin/stdout to the tty. *)
589 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
593 printf "virt-p2v.ml starting up ...\n%!";
595 (* Disable screen blanking on tty. *)
596 sh "setterm -blank 0";
598 (* Check that the environment is a sane-looking live CD. If not, bail. *)
599 if is_dir "/mnt/root" <> Some true then
601 "You should only run this script from the live CD or a USB key.";
603 printf "virt-p2v.ml detecting hard drives (this may take some time) ...\n%!";
605 (* Search for all non-removable block devices. Do this early and bail
606 * if we can't find anything. This is a list of strings, like "hda".
608 let all_block_devices : block_device list =
609 let rex = Pcre.regexp "^[hs]d" in
610 let devices = Array.to_list (Sys.readdir "/sys/block") in
611 let devices = List.sort devices in
612 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
613 eprintf "all_block_devices: block devices: %s\n%!"
614 (String.concat "; " devices);
615 (* Run blockdev --getsize64 on each, and reject any where this fails
616 * (probably removable devices).
618 let devices = List.filter_map (
620 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
621 let lines = shget cmd in
623 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
624 | Some [] | None -> None
626 eprintf "all_block_devices: non-removable block devices: %s\n%!"
628 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
630 fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
633 (* Search for partitions and LVs (anything that could contain a
634 * filesystem directly). We refer to these generically as
637 let all_partitions : partition list =
640 let lvs = get_lvs () in
641 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
642 let pvs = List.concat pvs in
643 let pvs = sort_uniq pvs in
644 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
645 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
646 eprintf "all_partitions: LVs: %s\n%!"
647 (String.concat "; " (List.map dev_of_partition lvs));
650 (* Partitions (eg. "sda1", "sda2"). *)
652 let parts = List.map fst all_block_devices in
653 let parts = List.map get_partitions parts in
654 let parts = List.concat parts in
655 eprintf "all_partitions: all partitions: %s\n%!"
656 (String.concat "; " (List.map dev_of_partition parts));
658 (* Remove any partitions which are PVs. *)
659 let parts = List.filter (
661 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
662 | LV _ -> assert false
665 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
666 (String.concat "; " (List.map dev_of_partition parts));
668 (* Concatenate LVs & Parts *)
671 (* Try to determine the nature of each partition.
672 * Root? Swap? Architecture? etc.
674 let all_partitions : (partition * nature) list =
675 (* Output of 'file' command for Linux swap file. *)
676 let swap = Pcre.regexp "Linux.*swap.*file" in
677 (* Contents of /etc/redhat-release. *)
678 let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
679 let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
680 (* Contents of /etc/debian_version. *)
681 let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
682 (* Output of 'file' on certain executables. *)
683 let i386 = Pcre.regexp ", Intel 80386," in
684 let x86_64 = Pcre.regexp ", x86-64," in
685 let itanic = Pcre.regexp ", IA-64," in
687 (* Examine the filesystem mounted on 'mnt' to determine the
688 * operating system, and, if Linux, the distro.
691 if is_dir (mnt ^ "/Windows") = Some true &&
692 is_file (mnt ^ "/autoexec.bat") = Some true then
694 else if is_dir (mnt ^ "/etc") = Some true &&
695 is_dir (mnt ^ "/sbin") = Some true &&
696 is_dir (mnt ^ "/var") = Some true then (
697 if is_file (mnt ^ "/etc/redhat-release") = Some true then (
698 let chan = open_in (mnt ^ "/etc/redhat-release") in
699 let lines = input_all_lines chan in
703 | [] -> (* empty /etc/redhat-release ...? *)
704 LinuxRoot (UnknownArch, OtherLinux)
705 | line::_ -> (* try to detect OS from /etc/redhat-release *)
707 let subs = Pcre.exec ~rex:rhel line in
708 let major = int_of_string (Pcre.get_substring subs 1) in
710 try int_of_string (Pcre.get_substring subs 2)
711 with Not_found -> 0 in
712 LinuxRoot (UnknownArch, RHEL (major, minor))
714 Not_found | Failure "int_of_string" ->
716 let subs = Pcre.exec ~rex:fedora line in
717 let version = int_of_string (Pcre.get_substring subs 1) in
718 LinuxRoot (UnknownArch, Fedora version)
720 Not_found | Failure "int_of_string" ->
721 LinuxRoot (UnknownArch, OtherLinux)
723 else if is_file (mnt ^ "/etc/debian_version") = Some true then (
724 let chan = open_in (mnt ^ "/etc/debian_version") in
725 let lines = input_all_lines chan in
729 | [] -> (* empty /etc/debian_version ...? *)
730 LinuxRoot (UnknownArch, OtherLinux)
731 | line::_ -> (* try to detect version from /etc/debian_version *)
733 let subs = Pcre.exec ~rex:debian line in
734 let major = int_of_string (Pcre.get_substring subs 1) in
735 let minor = int_of_string (Pcre.get_substring subs 2) in
736 LinuxRoot (UnknownArch, Debian (major, minor))
738 Not_found | Failure "int_of_string" ->
739 LinuxRoot (UnknownArch, OtherLinux)
742 LinuxRoot (UnknownArch, OtherLinux)
743 ) else if is_dir (mnt ^ "/grub") = Some true &&
744 is_file (mnt ^ "/grub/stage1") = Some true then (
747 NotRoot (* mountable, but not a root filesystem *)
750 (* Examine the Linux root filesystem mounted on 'mnt' to
751 * determine the architecture. We do this by looking at some
752 * well-known binaries that we expect to be there.
754 let detect_architecture mnt =
755 let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
757 | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
758 | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
759 | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
765 let dev = dev_of_partition part in (* Get /dev device. *)
768 (* Use 'file' command to detect if it is swap. *)
769 let cmd = "file -sbL " ^ quote dev in
771 | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
773 (* Blindly try to mount the device. *)
774 let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
775 match shwithstatus cmd with
777 let os = detect_os "/mnt/root" in
780 | LinuxRoot (UnknownArch, distro) ->
781 let architecture = detect_architecture "/mnt/root" in
782 LinuxRoot (architecture, distro)
784 sh "umount /mnt/root";
787 | _ -> UnknownNature (* not mountable *)
791 eprintf "partition detection: %s is %s\n%!"
792 dev (string_of_nature nature);
798 printf "virt-p2v.ml finished detecting hard drives\n%!";
801 let ask_greeting state =
802 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);
806 let ask_hostname state =
808 inputbox "Remote host" "Remote host" 10 50
809 (Option.default "" state.remote_host)
811 | Yes [] -> Ask_again
812 | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
813 | No | Help | Error -> Ask_again
819 inputbox "Remote port" "Remote port" 10 50
820 (Option.default "22" state.remote_port)
822 | Yes ([]|""::_) -> Next { state with remote_port = Some "22" }
823 | Yes (port::_) -> Next { state with remote_port = Some port }
824 | No | Help | Error -> Ask_again
828 let ask_directory state =
829 let default_dir = "/var/lib/xen/images" in
831 inputbox "Remote directory" "Remote directory" 10 50
832 (Option.default default_dir state.remote_directory)
834 | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir }
835 | Yes (dir::_) -> Next { state with remote_directory = Some dir }
836 | No | Help | Error -> Ask_again
840 let ask_username state =
841 let default_username = "root" in
843 inputbox "Remote username" "Remote username for ssh access to server" 10 50
844 (Option.default default_username state.remote_username)
847 Next { state with remote_username = Some default_username }
848 | Yes (user::_) -> Next { state with remote_username = Some user }
849 | No | Help | Error -> Ask_again
853 let ask_network state =
855 radiolist "Network configuration" "Network configuration" 10 50 2 [
856 "auto", "Automatic configuration", state.network = Some Auto;
857 "sh", "Configure from the shell", state.network = Some Shell;
860 | Yes ("auto"::_) -> Next { state with network = Some Auto }
861 | Yes ("sh"::_) -> Next { state with network = Some Shell }
862 | Yes _ | No | Help | Error -> Ask_again
866 let ask_devices state =
867 let selected_devices = Option.default [] state.devices_to_send in
868 let devices = List.map (
869 fun (dev, blksize) ->
871 sprintf "/dev/%s (%.3f GB)" dev
872 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
873 List.mem dev selected_devices)
874 ) all_block_devices in
876 checklist "Devices" "Pick devices to send" 15 50 8 devices
878 | Yes [] | No | Help | Error -> Ask_again
879 | Yes devices -> Next { state with devices_to_send = Some devices }
884 let parts = List.mapi (
885 fun i (part, nature) ->
888 | LinuxSwap -> " (Linux swap)"
889 | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
890 | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
891 | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
892 | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
893 | WindowsRoot -> " (Windows C:)"
894 | LinuxBoot -> " (Linux /boot)"
895 | NotRoot -> " (filesystem)"
896 | UnknownNature -> "" in
898 dev_of_partition part ^ descr,
899 Some part = state.root_filesystem)
902 radiolist "Root device"
903 "Pick partition containing the root (/) filesystem" 18 70 9
907 let (part, _) = List.nth all_partitions (int_of_string i) in
908 Next { state with root_filesystem = Some part }
909 | Yes [] | No | Help | Error -> Ask_again
913 let ask_hypervisor state =
915 radiolist "Hypervisor"
916 "Choose hypervisor / virtualization system"
918 "xen", "Xen", state.hypervisor = Some Xen;
919 "qemu", "QEMU", state.hypervisor = Some QEMU;
920 "kvm", "KVM", state.hypervisor = Some KVM;
921 "other", "Other", state.hypervisor = None
924 | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
925 | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
926 | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
927 | Yes _ -> Next { state with hypervisor = None }
928 | No | Help | Error -> Ask_again
932 let ask_architecture state =
934 radiolist "Architecture" "Machine architecture" 16 50 8 [
935 "i386", "i386 and up (32 bit)", state.architecture = Some I386;
936 "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
937 "ia64", "Itanium IA64", state.architecture = Some IA64;
938 "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
939 "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
940 "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
941 "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
942 "auto", "Auto-detect",
943 state.architecture = None || state.architecture = Some UnknownArch;
946 | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
947 | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
948 | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
949 | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
950 | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
951 | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
952 | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
953 | Yes _ -> Next { state with architecture = Some UnknownArch }
954 | No | Help | Error -> Ask_again
958 let ask_memory state =
960 inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
962 (Option.map_default string_of_int "" state.memory)
964 | Yes (""::_ | []) -> Next { state with memory = Some 0 }
966 let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
967 if mem < 0 || (mem > 0 && mem < 64) then Ask_again
968 else Next { state with memory = Some mem }
969 | No | Help | Error -> Ask_again
973 let ask_vcpus state =
975 inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
977 (Option.map_default string_of_int "" state.vcpus)
979 | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
982 try int_of_string vcpus with Failure "int_of_string" -> -1 in
983 if vcpus < 0 then Ask_again
984 else Next { state with vcpus = Some vcpus }
985 | No | Help | Error -> Ask_again
989 let ask_mac_address state =
991 inputbox "MAC address"
992 "Network MAC address. Leave blank to use a random address." 10 50
993 (Option.default "" state.mac_address)
995 | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
996 | Yes (mac :: _) -> Next { state with mac_address = Some mac }
997 | No | Help | Error -> Ask_again
1001 let ask_verify state =
1003 yesno "Verify and proceed"
1004 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
1016 (Option.default "" state.remote_host)
1017 (Option.default "" state.remote_port)
1018 (Option.default "" state.remote_directory)
1019 (match state.network with
1020 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
1022 (String.concat "," (Option.default [] state.devices_to_send))
1023 (Option.map_default dev_of_partition "" state.root_filesystem)
1024 (match state.hypervisor with
1025 | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
1026 | None -> "Other / not set")
1027 (match state.architecture with
1028 | Some UnknownArch -> "Auto-detect"
1029 | Some arch -> string_of_architecture arch | None -> "")
1030 (match state.memory with
1031 | Some 0 -> "Same as physical"
1032 | Some mem -> string_of_int mem ^ " MB" | None -> "")
1033 (match state.vcpus with
1034 | Some 0 -> "Same as physical"
1035 | Some vcpus -> string_of_int vcpus | None -> "")
1036 (match state.mac_address with
1037 | Some "" -> "Random" | Some mac -> mac | None -> "")
1041 | Yes _ -> Next state
1043 | No | Help | Error -> Ask_again
1046 (* This is the list of dialogs, in order. The user can go forwards or
1047 * backwards through them. The second parameter in each pair is
1048 * false if we need to skip this dialog (info already supplied in
1049 * 'defaults' above).
1052 ask_greeting, (* Initial greeting. *)
1054 ask_hostname, (* Hostname. *)
1055 defaults.remote_host = None;
1056 ask_port, (* Port number. *)
1057 defaults.remote_port = None;
1058 ask_directory, (* Remote directory. *)
1059 defaults.remote_directory = None;
1060 ask_username, (* Remote username. *)
1061 defaults.remote_username = None;
1062 ask_network, (* Network configuration. *)
1063 defaults.network = None;
1064 ask_devices, (* Block devices to send. *)
1065 defaults.devices_to_send = None;
1066 ask_root, (* Root filesystem. *)
1067 defaults.root_filesystem = None;
1068 ask_hypervisor, (* Hypervisor. *)
1069 defaults.hypervisor = None;
1070 ask_architecture, (* Architecture. *)
1071 defaults.architecture = None;
1072 ask_memory, (* Memory. *)
1073 defaults.memory = None;
1074 ask_vcpus, (* VCPUs. *)
1075 defaults.vcpus = None;
1076 ask_mac_address, (* MAC address. *)
1077 defaults.mac_address = None;
1078 ask_verify, (* Verify settings. *)
1082 (* Loop through the dialogs until we reach the end. *)
1083 let rec loop posn state =
1084 eprintf "dialog loop: posn = %d\n%!" posn;
1085 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
1087 let dlg, no_skip = dlgs.(posn) in
1088 let skip = not no_skip in
1090 (* Skip this dialog and move straight to the next one. *)
1094 match dlg state with
1095 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
1096 | Prev -> loop (posn-1) state (* Backwards / back button. *)
1097 | Ask_again -> loop posn state (* Repeat the question. *)
1101 let state = loop 0 defaults in
1103 eprintf "finished dialog loop\n%!";
1105 (* Switch LVM config. *)
1107 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1108 sh "rm -f /etc/lvm/cache/.cache";
1109 sh "rm -f /etc/lvm.new/cache/.cache";
1111 (* Snapshot the block devices to send. *)
1112 let devices_to_send = Option.get state.devices_to_send in
1113 let devices_to_send =
1116 let snapshot_dev = snapshot_name origin_dev in
1117 snapshot origin_dev snapshot_dev;
1118 (origin_dev, snapshot_dev)
1119 ) devices_to_send in
1121 (* Run kpartx on the snapshots. *)
1123 fun (origin, snapshot) ->
1124 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1127 (* Rescan for LVs. *)
1131 (* Mount the root filesystem under /mnt/root. *)
1132 let root_filesystem = Option.get state.root_filesystem in
1133 (match root_filesystem with
1134 | Part (dev, partnum) ->
1135 let dev = dev ^ partnum in
1136 let snapshot_dev = snapshot_name dev in
1137 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1140 (* The LV will be backed by a snapshot device, so just mount
1143 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1146 (* See if we can do network configuration. *)
1147 let network = Option.get state.network in
1150 printf "Network configuration.\n\n";
1151 printf "Please configure the network from this shell.\n\n";
1152 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1157 "Trying network auto-configuration from root filesystem ...\n\n%!";
1158 if not (auto_network state) then (
1159 printf "\nAuto-configuration failed. Starting a shell.\n\n";
1160 printf "Please configure the network from this shell.\n\n";
1161 printf "When you have finished, exit the shell with ^D or exit.\n\n";
1166 (* Work out what devices will be called at the remote end. *)
1167 let devices_to_send = List.map (
1168 fun (origin_dev, snapshot_dev) ->
1169 let remote_dev = remote_of_origin_dev origin_dev in
1170 (origin_dev, snapshot_dev, remote_dev)
1171 ) devices_to_send in
1173 (* Modify files on the root filesystem. *)
1174 rewrite_fstab state devices_to_send;
1175 (* XXX Other files to rewrite? *)
1177 (* Unmount the root filesystem and sync disks. *)
1178 sh "umount /mnt/root";
1179 sh "sync"; (* Ugh, should be in stdlib. *)
1181 (* Get architecture of root filesystem, detected previously. *)
1182 let system_architecture =
1184 (match List.assoc root_filesystem all_partitions with
1185 | LinuxRoot (arch, _) -> arch
1186 | _ -> raise Not_found
1190 (* None was detected before, so assume same as live CD. *)
1191 let arch = shget "uname -m" in
1193 | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
1194 | Some ("x86_64"::_) -> X86_64
1195 | Some ("ia64"::_) -> IA64
1196 | _ -> I386 (* probably wrong XXX *) in
1198 (* Autodetect system memory. *)
1200 let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
1202 | Some (mem::_) -> int_of_float (float_of_string mem)
1205 (* Autodetect system # pCPUs. *)
1206 let system_nr_cpus =
1208 shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
1210 | Some (cpus::_) -> int_of_string cpus
1213 let remote_host = Option.get state.remote_host in
1214 let remote_port = Option.get state.remote_port in
1215 let remote_directory = Option.get state.remote_directory in
1216 let remote_username = Option.get state.remote_username in
1218 (* Functions to connect and disconnect from the remote system. *)
1219 let do_connect remote_name _ =
1220 let cmd = sprintf "ssh -C -l %s -p %s %s \"cat > %s/%s\""
1221 (quote remote_username) (quote remote_port) (quote remote_host)
1222 (quote remote_directory) (quote remote_name) in
1223 eprintf "connect: %s\n%!" cmd;
1224 let chan = open_process_out cmd in
1225 descr_of_out_channel chan, chan
1227 let do_disconnect (_, chan) =
1228 match close_process_out chan with
1229 | WEXITED 0 -> () (* OK *)
1230 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
1231 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
1232 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
1235 (* XXX This is using the hostname derived from network configuration
1236 * above. We might want to ask the user to choose.
1238 let hostname = safe_name (gethostname ()) in
1240 let date = sprintf "%04d%02d%02d%02d%02d"
1241 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1242 "p2v-" ^ hostname ^ "-" ^ date in
1244 (* Work out what the image filenames will be at the remote end. *)
1245 let devices_to_send = List.map (
1246 fun (origin_dev, snapshot_dev, remote_dev) ->
1247 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1248 (origin_dev, snapshot_dev, remote_dev, remote_name)
1249 ) devices_to_send in
1251 (* Write a configuration file. Not sure if this is any better than
1252 * just 'sprintf-ing' bits of XML text together, but at least we will
1253 * always get well-formed XML.
1255 * XXX For some of the stuff here we really should do a
1256 * virConnectGetCapabilities call to the remote host first.
1258 * XXX There is a case for using virt-install to generate this XML.
1259 * When we start to incorporate libvirt access & storage API this
1260 * needs to be rethought.
1262 let conf_filename = basename ^ ".conf" in
1265 match state.architecture with
1266 | Some UnknownArch | None -> system_architecture
1267 | Some arch -> arch in
1269 match state.memory with
1270 | Some 0 | None -> system_memory
1271 | Some memory -> memory in
1273 match state.vcpus with
1274 | Some 0 | None -> system_nr_cpus
1277 match state.mac_address with
1280 List.map (sprintf "%02x") (
1281 List.map (fun _ -> Random.int 256) [0;0;0]
1283 String.concat ":" ("00"::"16"::"3e"::random)
1284 | Some mac -> mac in
1287 (* Shortcut to make "<name>value</name>". *)
1288 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1289 (* ... and the _other_ sort of leaf (god I hate XML). *)
1290 let tleaf name attribs = Xml.Element (name, attribs, []) in
1292 (* Standard stuff for every domain. *)
1293 let name = leaf "name" hostname in
1294 let memory = leaf "memory" (string_of_int (memory * 1024)) in
1295 let vcpu = leaf "vcpu" (string_of_int vcpus) in
1297 (* Top-level stuff which differs for each HV type (isn't this supposed
1298 * to be portable ...)
1301 match state.hypervisor with
1303 [Xml.Element ("os", [],
1305 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1306 tleaf "boot" ["dev", "hd"]]);
1307 Xml.Element ("features", [],
1311 tleaf "clock" ["sync", "localtime"]]
1313 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1314 tleaf "clock" ["sync", "localtime"]]
1316 [Xml.Element ("os", [],
1317 [Xml.Element ("type",
1319 string_of_architecture architecture;
1321 [Xml.PCData "hvm"]);
1322 tleaf "boot" ["dev", "hd"]])]
1326 (* <devices> section. *)
1329 match state.hypervisor with
1331 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1333 [leaf "emulator" "/usr/bin/qemu"]
1335 [leaf "emulator" "/usr/bin/qemu-kvm"]
1339 Xml.Element ("interface", ["type", "user"],
1340 [tleaf "mac" ["address", mac_address]]) in
1341 (* XXX should have an option for Xen bridging:
1343 "interface", ["type","bridge"],
1344 [tleaf "source" ["bridge","xenbr0"];
1345 tleaf "mac" ["address",mac_address];
1346 tleaf "script" ["path","vif-bridge"]])*)
1347 let graphics = tleaf "graphics" ["type", "vnc"] in
1349 let disks = List.map (
1350 fun (_, _, remote_dev, remote_name) ->
1352 "disk", ["type", "file";
1354 [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1355 tleaf "target" ["dev", remote_dev]]
1357 ) devices_to_send in
1361 emulator @ interface :: graphics :: disks
1364 (* Put it all together in <domain type='foo'>. *)
1367 (match state.hypervisor with
1368 | Some Xen -> ["type", "xen"]
1369 | Some QEMU -> ["type", "qemu"]
1370 | Some KVM -> ["type", "kvm"]
1372 name :: memory :: vcpu :: extras @ [devices]
1375 let xml = Xml.to_string_fmt xml in
1376 let xml_len = String.length xml in
1377 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1379 let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1380 (* In OCaml this actually loops calling write(2) *)
1381 ignore (write sock xml 0 xml_len);
1384 (* Send the device snapshots to the remote host. *)
1385 (* XXX This code should be made more robust against both network
1386 * errors and local I/O errors. Also should allow the user several
1387 * attempts to connect, or let them go back to the dialog stage.
1390 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1391 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1394 try List.assoc origin_dev all_block_devices
1395 with Not_found -> assert false (* internal error *) in
1397 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1398 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1400 (* Open the snapshot device. *)
1401 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1404 let (sock,_) as conn = do_connect remote_name size in
1406 (* Copy the data. *)
1407 let bufsize = 1024 * 1024 in
1408 let buffer = String.create bufsize in
1409 let start = gettimeofday () in
1411 let rec copy bytes_sent last_printed_at =
1412 let n = read fd buffer 0 bufsize in
1414 ignore (write sock buffer 0 n);
1416 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1417 let last_printed_at =
1418 let now = gettimeofday () in
1419 (* Print progress once per second. *)
1420 if now -. last_printed_at > 1. then (
1421 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1422 let secs_elapsed = now -. start in
1423 printf "%.0f%%" (100. *. elapsed);
1424 (* After 60 seconds has elapsed, start printing estimates. *)
1425 if secs_elapsed >= 60. then (
1426 let remaining = 1. -. elapsed in
1427 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1428 if secs_remaining > 120. then
1429 printf " (about %.0f minutes remaining) "
1430 (secs_remaining /. 60.)
1432 printf " (about %.0f seconds remaining) "
1438 else last_printed_at in
1440 copy bytes_sent last_printed_at
1449 (* Clean up and reboot. *)
1451 msgbox "virt-p2v completed"
1452 (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."
1453 remote_directory conf_filename)
1462 eprintf "usage: virt-p2v [ttyname]\n%!";
1465 (* Make sure that exceptions from 'main' get printed out on stdout
1466 * as well as stderr, since stderr is probably redirected to the
1467 * logfile, and so not visible to the user.
1469 let handle_exn f arg =
1471 with exn -> print_endline (Printexc.to_string exn); raise exn
1473 (* If the ISO image has an attachment then it could be a new version
1474 * of virt-p2v.ml (this script). Get the attachment and run it
1475 * instead. Useful mainly for testing, in conjunction with the
1476 * 'make update' target in the virt-p2v Makefile.
1478 let magic = "ISOATTACHMENT002"
1479 let magiclen = String.length magic (* = 16 bytes *)
1480 let trailerlen = magiclen + 8 + 8 (* magic + file start + true size *)
1482 let int64_of_string str =
1484 let add offs shift =
1487 (Int64.shift_left (Int64.of_int (Char.code str.[offs])) shift) !i
1489 add 0 56; add 1 48; add 2 40; add 3 32;
1490 add 4 24; add 5 16; add 6 8; add 7 0;
1493 let update ttyname =
1494 let cdrom = "/dev/cdrom" in
1495 let output = "/tmp/virt-p2v.ml" in
1498 let fd = openfile cdrom [O_RDONLY] 0 in
1499 ignore (LargeFile.lseek fd (Int64.of_int ~-trailerlen) SEEK_END);
1500 let buf = String.create magiclen in
1501 if read fd buf 0 magiclen <> magiclen || buf <> magic then (
1506 (* Read the size. *)
1507 let buf = String.create 8 in
1508 if read fd buf 0 8 <> 8 then
1509 failwith "cannot read attachment offset";
1510 let offset = int64_of_string buf in
1511 let buf = String.create 8 in
1512 if read fd buf 0 8 <> 8 then
1513 failwith "cannot read attachment size";
1514 let size = Int64.to_int (int64_of_string buf) in
1516 (* Seek to beginning of the attachment. *)
1517 ignore (LargeFile.lseek fd offset SEEK_SET);
1519 (* Copy out the attachment. *)
1520 let fd2 = openfile output [O_WRONLY; O_CREAT; O_TRUNC] 0o755 in
1521 let bufsize = 4 * 1024 in
1522 let buffer = String.create bufsize in
1523 let rec copy remaining =
1524 if remaining > 0 then (
1525 let n = min remaining bufsize in
1526 let n = read fd buffer 0 n in
1527 if n = 0 then failwith "corrupted or partial attachment";
1528 ignore (write fd2 buffer 0 n);
1529 copy (remaining - n)
1537 (* Run updated virt-p2v script. *)
1538 execv output [| output; ttyname |]
1540 Unix_error _ | Exit ->
1541 (* Some error, or no attachment, so keep running this script. *)
1542 handle_exn main (Some ttyname)
1544 (* Test harness for the Makefile. The Makefile invokes this script as
1545 * 'virt-p2v.ml --test' just to check it compiles. When it is running
1546 * from the actual live CD, there is a single parameter which is the
1547 * tty name (so usually 'virt-p2v.ml tty1').
1550 match Array.to_list Sys.argv with
1551 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1552 | [ _; "--update"; ttyname ] -> (* Test for update and run. *)
1554 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1555 | [ _; ttyname ] -> (* Run main with ttyname. *)
1556 handle_exn main (Some ttyname)
1557 | [ _ ] -> (* Interactive - no ttyname. *)
1558 handle_exn main None
1561 (* This file must end with a newline *)