1 #!/usr/bin/ocamlrun /usr/bin/ocaml
8 (* virt-p2v.ml is a script which performs a physical to
9 * virtual conversion of local disks.
11 * Copyright (C) 2007-2008 Red Hat Inc.
12 * Written by Richard W.M. Jones <rjones@redhat.com>
14 * This program is free software; you can redistribute it and/or modify
15 * it under the terms of the GNU General Public License as published by
16 * the Free Software Foundation; either version 2 of the License, or
17 * (at your option) any later version.
19 * This program is distributed in the hope that it will be useful,
20 * but WITHOUT ANY WARRANTY; without even the implied warranty of
21 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 * GNU General Public License for more details.
24 * You should have received a copy of the GNU General Public License
25 * along with this program; if not, write to the Free Software
26 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
34 type state = { greeting : bool;
35 remote_host : string option; remote_port : string option;
36 transport : transport option;
37 remote_directory : string option;
38 network : network option;
39 devices_to_send : string list option;
40 root_filesystem : partition option }
41 and transport = Server | SSH | TCP
42 and network = Auto | Shell
43 and partition = Part of string * string (* eg. "hda", "1" *)
44 | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
46 (*----------------------------------------------------------------------*)
47 (* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
49 * If left as they are, then this will create a generic virt-p2v script
50 * which asks the user for each question. If you set the defaults here
51 * then you will get a custom virt-p2v which is partially or even fully
52 * automated and won't ask the user any questions.
54 * Note that 'None' means 'no default' (ie. ask the user) whereas
55 * 'Some foo' means use 'foo' as the answer.
58 (* If greeting is true, wait for keypress after boot and during
59 * final verification. Set to 'false' for less interactions.
63 (* Transport: Set to 'Some Server' or 'Some SSH' or 'Some TCP' to
64 * assume Server, SSH or TCP transports respectively.
68 (* Remote host and port. Set to 'Some "host"' and 'Some "port"',
74 (* Remote directory (only for SSH transport). Set to 'Some "path"'
75 * to set up a directory path, else ask the user.
77 remote_directory = None;
79 (* List of devices to send. Set to 'Some ["sda"; "sdb"]' for
80 * example to select /dev/sda and /dev/sdb.
82 devices_to_send = None;
84 (* The root filesystem containing /etc/fstab. Set to
85 * 'Some (Part ("sda", "3"))' or 'Some (LV ("VolGroup00", "LogVol00"))'
86 * for example, else ask user.
88 root_filesystem = None;
90 (* Network configuration: Set to 'Some Auto' (try to set it up
91 * automatically, or 'Some Shell' (give the user a shell).
95 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
96 (*----------------------------------------------------------------------*)
98 (* General helper functions. *)
100 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
101 let xs = List.sort ~cmp xs in
102 let rec loop = function
103 | [] -> [] | [x] -> [x]
104 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
105 | x :: xs -> x :: loop xs
109 let input_all_lines chan =
110 let lines = ref [] in
112 while true do lines := input_line chan :: !lines done; []
114 End_of_file -> List.rev !lines
116 let rec string_of_state state =
118 "greeting: %b remote: %s:%s%s%s network: %s devices: [%s] root: %s"
120 (Option.default "" state.remote_host)
121 (Option.default "" state.remote_port)
122 (match state.transport with
124 | Some Server -> " (server)" | Some SSH -> " (ssh)" | Some TCP -> " (tcp)")
125 (match state.remote_directory with
126 | None -> "" | Some dir -> " " ^ dir)
127 (match state.network with
128 | None -> "none" | Some Auto -> "auto" | Some Shell -> "shell")
129 (String.concat "; " (Option.default [] state.devices_to_send))
130 (Option.map_default dev_of_partition "" state.root_filesystem)
132 and dev_of_partition = function
133 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
134 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
136 type dialog_status = Yes of string list | No | Help | Back | Error
138 type ask_result = Next of state | Prev | Ask_again
142 * Each function takes some common parameters (eg. ~title) and some
143 * dialog-specific parameters.
145 * Returns the exit status (Yes lines | No | Help | Back | Error).
147 let msgbox, yesno, inputbox, radiolist, checklist =
148 (* Internal function to actually run the "dialog" shell command. *)
149 let run_dialog cparams params =
150 let params = cparams @ params in
151 eprintf "dialog %s\n%!"
152 (String.concat " " (List.map (sprintf "%S") params));
154 (* 'dialog' writes its output/result to stderr, so we need to take
155 * special steps to capture that - in other words, manual pipe/fork.
157 let rfd, wfd = pipe () in
159 | 0 -> (* child, runs dialog *)
161 dup2 wfd stderr; (* capture stderr to pipe *)
162 execvp "dialog" (Array.of_list ("dialog" :: params))
163 | pid -> (* parent *)
165 let chan = in_channel_of_descr rfd in
166 let result = input_all_lines chan in
168 eprintf "dialog result: %S\n%!" (String.concat "\n" result);
169 match snd (wait ()) with
170 | WEXITED 0 -> Yes result (* something selected / entered *)
171 | WEXITED 1 -> No (* cancel / no button *)
172 | WEXITED 2 -> Help (* help pressed *)
173 | WEXITED 3 -> Back (* back button *)
174 | WEXITED _ -> Error (* error or Esc *)
175 | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
176 | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
179 (* Handle the common parameters. Note Continuation Passing Style. *)
180 let with_common cont ?(cancel=false) ?(backbutton=true) title =
181 let params = ["--title"; title] in
182 let params = if not cancel then "--nocancel" :: params else params in
184 if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
189 (* Message box and yes/no box. *)
192 fun cparams text height width ->
194 [ "--msgbox"; text; string_of_int height; string_of_int width ]
198 fun cparams text height width ->
200 [ "--yesno"; text; string_of_int height; string_of_int width ]
203 (* Simple input box. *)
206 fun cparams text height width default ->
208 [ "--inputbox"; text; string_of_int height; string_of_int width;
212 (* Radio list and check list. *)
215 fun cparams text height width listheight items ->
216 let items = List.map (
218 | tag, item, true -> [ tag; item; "on" ]
219 | tag, item, false -> [ tag; item; "off" ]
221 let items = List.concat items in
222 let items = "--single-quoted" ::
223 "--radiolist" :: text ::
224 string_of_int height :: string_of_int width ::
225 string_of_int listheight :: items in
226 run_dialog cparams items
230 fun cparams text height width listheight items ->
231 let items = List.map (
233 | tag, item, true -> [ tag; item; "on" ]
234 | tag, item, false -> [ tag; item; "off" ]
236 let items = List.concat items in
237 let items = "--separate-output" ::
238 "--checklist" :: text ::
239 string_of_int height :: string_of_int width ::
240 string_of_int listheight :: items in
241 run_dialog cparams items
244 msgbox, yesno, inputbox, radiolist, checklist
246 (* Print failure dialog and exit. *)
247 let fail_dialog text =
248 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
249 ignore (msgbox "Error" text 17 50);
252 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
253 let quote = Filename.quote
255 (* Run a shell command and check it returns 0. *)
257 eprintf "sh: %s\n%!" cmd;
258 if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
261 eprintf "shfailok: %s\n%!" cmd;
262 ignore (Sys.command cmd)
264 let shwithstatus cmd =
265 eprintf "shwithstatus: %s\n%!" cmd;
268 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
270 eprintf "shget: %s\n%!" cmd;
271 let chan = open_process_in cmd in
272 let lines = input_all_lines chan in
273 match close_process_in chan with
274 | WEXITED 0 -> Some lines (* command succeeded *)
275 | WEXITED _ -> None (* command failed *)
276 | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
277 | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
279 (* Start an interactive shell. *)
281 shfailok "PS1='\\u@\\h:\\w\\$ ' bash"
283 (* Some true if is dir/file, Some false if not, None if not found. *)
285 try Some ((stat path).st_kind = S_DIR)
286 with Unix_error (ENOENT, "stat", _) -> None
288 try Some ((stat path).st_kind = S_REG)
289 with Unix_error (ENOENT, "stat", _) -> None
291 (* Useful regular expression. *)
292 let whitespace = Pcre.regexp "[ \t]+"
294 (* Generate a predictable safe name containing only letters, numbers
295 * and underscores. If passed a string with no letters or numbers,
296 * generates "_1", "_2", etc.
301 fun () -> incr i; "_" ^ string_of_int !i
304 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
305 let name = String.copy name in
306 let have_safe = ref false in
307 for i = 0 to String.length name - 1 do
308 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
310 if !have_safe then name else next_anon ()
312 type block_device = string * int64 (* "hda" & size in bytes *)
314 (* Parse the output of 'lvs' to get list of LV names, sizes,
315 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
318 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
322 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
326 let lines = List.map (Pcre.split ~rex:whitespace) lines in
329 | [vg; lv; pvs; lvsize]
330 | [_; vg; lv; pvs; lvsize] ->
331 let pvs = String.nsplit pvs "," in
332 let pvs = List.filter_map (
335 let subs = Pcre.exec ~rex:devname pv in
336 Some (Pcre.get_substring subs 1)
339 eprintf "lvs: unexpected device name: %s\n%!" pv;
342 LV (vg, lv), pvs, lvsize
344 failwith ("lvs: unexpected output: " ^ String.concat "," line)
347 (* Get the partitions on a block device.
348 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
350 let get_partitions dev =
351 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
352 let devdir = "/sys/block/" ^ dev in
353 let parts = Sys.readdir devdir in
354 let parts = Array.to_list parts in
355 let parts = List.filter (
356 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
358 let parts = List.filter_map (
361 let subs = Pcre.exec ~rex part in
362 Some (Part (dev, Pcre.get_substring subs 1))
368 (* Generate snapshot device name from device name. *)
369 let snapshot_name dev =
370 "snap" ^ (safe_name dev)
372 (* Perform a device-mapper snapshot with ramdisk overlay. *)
374 let next_free_ram_disk =
376 fun () -> incr i; "/dev/ram" ^ string_of_int !i
378 fun origin_dev snapshot_dev ->
379 let ramdisk = next_free_ram_disk () in
381 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
382 let lines = shget cmd in
384 | Some (sectors::_) -> Int64.of_string sectors
386 fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
388 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
389 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
390 snapshot_dev sectors origin_dev);
391 (* Create the snapshot. *)
392 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
393 snapshot_dev sectors snapshot_dev ramdisk)
395 (* Try to perform automatic network configuration, assuming a Fedora or RHEL-
396 * like root filesystem mounted on /mnt/root.
398 let auto_network state =
399 (* Fedora gives an error if this file doesn't exist. *)
400 sh "touch /etc/resolv.conf";
402 chdir "/etc/sysconfig";
404 sh "mv network network.saved";
405 sh "mv networking networking.saved";
406 sh "mv network-scripts network-scripts.saved";
408 (* Originally I symlinked these, but that causes dhclient to
409 * keep open /mnt/root (as its cwd is in network-scripts subdir).
410 * So now we will copy them recursively instead.
412 sh "cp -r /mnt/root/etc/sysconfig/network .";
413 sh "cp -r /mnt/root/etc/sysconfig/networking .";
414 sh "cp -r /mnt/root/etc/sysconfig/network-scripts .";
416 let status = shwithstatus "/etc/init.d/network start" in
418 sh "rm -rf network networking network-scripts";
419 sh "mv network.saved network";
420 sh "mv networking.saved networking";
421 sh "mv network-scripts.saved network-scripts";
425 (* Try to ping the remote host to see if this worked. *)
426 shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
428 if state.greeting then (
429 printf "\n\nDid automatic network configuration work?\n";
430 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
432 let line = read_line () in
433 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
436 (* Non-interactive: return the status of /etc/init.d/network start. *)
439 (* Map local device names to remote devices names. At the moment we
440 * just change sd* to hd* (as device names appear under fullvirt). In
441 * future, lots of complex possibilities.
443 let remote_of_origin_dev =
444 let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
445 let devsd_subst = Pcre.subst "hd$1" in
447 Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
449 (* Rewrite /mnt/root/etc/fstab. *)
450 let rewrite_fstab state devices_to_send =
451 let filename = "/mnt/root/etc/fstab" in
452 if is_file filename = Some true then (
453 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
455 let chan = open_in filename in
456 let lines = input_all_lines chan in
458 let lines = List.map (Pcre.split ~rex:whitespace) lines in
459 let lines = List.map (
461 | dev :: rest when String.starts_with dev "/dev/" ->
462 let dev = String.sub dev 5 (String.length dev - 5) in
463 let dev = remote_of_origin_dev dev in
464 let dev = "/dev/" ^ dev in
469 let chan = open_out filename in
472 | [dev; mountpoint; fstype; options; freq; passno] ->
473 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
474 dev mountpoint fstype options freq passno
476 output_string chan (String.concat " " line)
481 (* Main entry point. *)
482 let rec main ttyname =
483 (* Running from an init script. We don't have much of a
484 * login environment, so set one up.
488 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
489 "/usr/bin"; "/bin"]);
490 putenv "HOME" "/root";
491 putenv "LOGNAME" "root";
493 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
496 (* Set up logging to /tmp/virt-p2v.log. *)
497 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
501 (* Log the start up time. *)
502 eprintf "\n\n**************************************************\n\n";
503 let tm = localtime (time ()) in
504 eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
505 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
507 (* Connect stdin/stdout to the tty. *)
511 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
515 printf "virt-p2v.ml starting up ...\n%!";
517 (* Search for all non-removable block devices. Do this early and bail
518 * if we can't find anything. This is a list of strings, like "hda".
520 let all_block_devices : block_device list =
521 let rex = Pcre.regexp "^[hs]d" in
522 let devices = Array.to_list (Sys.readdir "/sys/block") in
523 let devices = List.sort devices in
524 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
525 eprintf "all_block_devices: block devices: %s\n%!"
526 (String.concat "; " devices);
527 (* Run blockdev --getsize64 on each, and reject any where this fails
528 * (probably removable devices).
530 let devices = List.filter_map (
532 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
533 let lines = shget cmd in
535 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
536 | Some [] | None -> None
538 eprintf "all_block_devices: non-removable block devices: %s\n%!"
540 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
542 fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
545 (* Search for partitions and LVs (anything that could contain a
546 * filesystem directly). We refer to these generically as
549 let all_partitions : partition list =
552 let lvs = get_lvs () in
553 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
554 let pvs = List.concat pvs in
555 let pvs = sort_uniq pvs in
556 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
557 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
558 eprintf "all_partitions: LVs: %s\n%!"
559 (String.concat "; " (List.map dev_of_partition lvs));
562 (* Partitions (eg. "sda1", "sda2"). *)
564 let parts = List.map fst all_block_devices in
565 let parts = List.map get_partitions parts in
566 let parts = List.concat parts in
567 eprintf "all_partitions: all partitions: %s\n%!"
568 (String.concat "; " (List.map dev_of_partition parts));
570 (* Remove any partitions which are PVs. *)
571 let parts = List.filter (
573 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
574 | LV _ -> assert false
577 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
578 (String.concat "; " (List.map dev_of_partition parts));
580 (* Concatenate LVs & Parts *)
584 let ask_greeting state =
585 ignore (msgbox "virt-p2v" "\nUPDATED! Welcome 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);
589 let ask_transport state =
591 radiolist "Connection type" ~backbutton:false
592 "Connection type. If possible, select 'server' and run P2V server on the remote host"
594 "server", "P2V server on remote host",
595 state.transport = Some Server;
596 "ssh", "SSH (secure shell)",
597 state.transport = Some SSH;
599 state.transport = Some TCP
602 | Yes ("server"::_) -> Next { state with transport = Some Server }
603 | Yes ("ssh"::_) -> Next { state with transport = Some SSH }
604 | Yes ("tcp"::_) -> Next { state with transport = Some TCP }
605 | Yes _ | No | Help | Error -> Ask_again
609 let ask_hostname state =
611 inputbox "Remote host" "Remote host" 10 50
612 (Option.default "" state.remote_host)
614 | Yes [] -> Ask_again
615 | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
616 | No | Help | Error -> Ask_again
622 inputbox "Remote port" "Remote port" 10 50
623 (Option.default "" state.remote_port)
626 (match state.transport with
627 | Some SSH -> Next { state with remote_port = Some "22" }
628 | _ -> Next { state with remote_port = Some "16211" }
630 | Yes (port::_) -> Next { state with remote_port = Some port }
631 | No | Help | Error -> Ask_again
635 let ask_directory state =
637 inputbox "Remote directory" "Remote directory" 10 50
638 (Option.default "" state.remote_directory)
641 Next { state with remote_directory = Some "/var/lib/xen/images" }
642 | Yes (dir::_) -> Next { state with remote_directory = Some dir }
643 | No | Help | Error -> Ask_again
647 let ask_network state =
649 radiolist "Network configuration" "Network configuration" 10 50 2 [
650 "auto", "Automatic configuration", state.network = Some Auto;
651 "sh", "Configure from the shell", state.network = Some Shell;
654 | Yes ("auto"::_) -> Next { state with network = Some Auto }
655 | Yes ("sh"::_) -> Next { state with network = Some Shell }
656 | Yes _ | No | Help | Error -> Ask_again
660 let ask_devices state =
661 let selected_devices = Option.default [] state.devices_to_send in
662 let devices = List.map (
663 fun (dev, blksize) ->
665 sprintf "/dev/%s (%.3f GB)" dev
666 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
667 List.mem dev selected_devices)
668 ) all_block_devices in
670 checklist "Devices" "Pick devices to send" 15 50 8 devices
672 | Yes [] | No | Help | Error -> Ask_again
673 | Yes devices -> Next { state with devices_to_send = Some devices }
678 let parts = List.mapi (
680 (string_of_int i, dev_of_partition part,
681 Some part = state.root_filesystem)
684 radiolist "Root device"
685 "Pick partition containing the root (/) filesystem" 15 50 6
689 let part = List.nth all_partitions (int_of_string i) in
690 Next { state with root_filesystem = Some part }
691 | Yes [] | No | Help | Error -> Ask_again
695 let ask_verify state =
697 yesno "Verify and proceed"
698 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
707 (match state.transport with
708 | Some Server -> "Server"
709 | Some SSH -> "SSH" | Some TCP -> "TCP socket"
711 (Option.default "" state.remote_host)
712 (Option.default "" state.remote_port)
713 (Option.default "" state.remote_directory)
714 (match state.network with
715 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
717 (String.concat "," (Option.default [] state.devices_to_send))
718 (Option.map_default dev_of_partition "" state.root_filesystem))
721 | Yes _ -> Next state
723 | No | Help | Error -> Ask_again
726 (* This is the list of dialogs, in order. The user can go forwards or
727 * backwards through them. The second parameter in each pair is
728 * false if we need to skip this dialog (info already supplied in
732 ask_greeting, (* Initial greeting. *)
734 ask_transport, (* Transport (ssh, tcp) *)
735 defaults.transport = None;
736 ask_hostname, (* Hostname. *)
737 defaults.remote_host = None;
738 ask_port, (* Port number. *)
739 defaults.remote_port = None;
740 ask_directory, (* Remote directory. *)
741 defaults.remote_directory = None;
742 ask_network, (* Network configuration. *)
743 defaults.network = None;
744 ask_devices, (* Block devices to send. *)
745 defaults.devices_to_send = None;
746 ask_root, (* Root filesystem. *)
747 defaults.root_filesystem = None;
748 ask_verify, (* Verify settings. *)
752 (* Loop through the dialogs until we reach the end. *)
753 let rec loop posn state =
754 eprintf "dialog loop: posn = %d\n%!" posn;
755 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
757 let dlg, no_skip = dlgs.(posn) in
758 let skip = not no_skip in
760 (* Skip this dialog and move straight to the next one. *)
765 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
766 | Prev -> loop (posn-1) state (* Backwards / back button. *)
767 | Ask_again -> loop posn state (* Repeat the question. *)
771 let state = loop 0 defaults in
773 eprintf "finished dialog loop\nfinal state = %s\n%!" (string_of_state state);
775 (* Check that the environment is a sane-looking live CD. If not, bail. *)
776 if is_dir "/mnt/root" <> Some true then
777 fail_dialog "You should only run this script from the live CD or a USB key.";
779 (* Switch LVM config. *)
781 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
782 sh "rm -f /etc/lvm/cache/.cache";
783 sh "rm -f /etc/lvm.new/cache/.cache";
785 (* Snapshot the block devices to send. *)
786 let devices_to_send = Option.get state.devices_to_send in
787 let devices_to_send =
790 let snapshot_dev = snapshot_name origin_dev in
791 snapshot origin_dev snapshot_dev;
792 (origin_dev, snapshot_dev)
795 (* Run kpartx on the snapshots. *)
797 fun (origin, snapshot) ->
798 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
801 (* Rescan for LVs. *)
805 (* Mount the root filesystem under /mnt/root. *)
806 let root_filesystem = Option.get state.root_filesystem in
807 (match root_filesystem with
808 | Part (dev, partnum) ->
809 let dev = dev ^ partnum in
810 let snapshot_dev = snapshot_name dev in
811 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
814 (* The LV will be backed by a snapshot device, so just mount
817 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
820 (* See if we can do network configuration. *)
821 let network = Option.get state.network in
824 printf "Network configuration.\n\n";
825 printf "Please configure the network from this shell.\n\n";
826 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
831 "Trying network auto-configuration from root filesystem ...\n\n%!";
832 if not (auto_network state) then (
833 printf "\nAuto-configuration failed. Starting a shell.\n\n";
834 printf "Please configure the network from this shell.\n\n";
835 printf "When you have finished, exit the shell with ^D or exit.\n\n";
840 (* Work out what devices will be called at the remote end. *)
841 let devices_to_send = List.map (
842 fun (origin_dev, snapshot_dev) ->
843 let remote_dev = remote_of_origin_dev origin_dev in
844 (origin_dev, snapshot_dev, remote_dev)
847 (* Modify files on the root filesystem. *)
848 rewrite_fstab state devices_to_send;
849 (* XXX Other files to rewrite? *)
851 (* Unmount the root filesystem and sync disks. *)
852 sh "umount /mnt/root";
853 sh "sync"; (* Ugh, should be in stdlib. *)
855 (* Disable screen blanking on console. *)
856 sh "setterm -blank 0";
858 (* For Server and TCP type connections, we connect just once. *)
859 let remote_host = Option.get state.remote_host in
860 let remote_port = Option.get state.remote_port in
861 let remote_directory = Option.get state.remote_directory in
862 let transport = Option.get state.transport in
868 getaddrinfo remote_host remote_port [AI_SOCKTYPE SOCK_STREAM] in
869 let rec loop = function
872 (sprintf "Unable to connect to %s:%s" remote_host remote_port)
876 socket addr.ai_family addr.ai_socktype addr.ai_protocol in
877 connect sock addr.ai_addr;
879 with Unix_error (err, syscall, extra) ->
880 (* Log the error message, but continue around the loop. *)
881 eprintf "%s:%s: %s\n%!" syscall extra (error_message err);
886 (* Just dummy socket for SSH for now ... *) stdin in
888 (* Send the device snapshots to the remote host. *)
889 (* XXX This is using the hostname derived from network configuration
890 * above. We might want to ask the user to choose.
893 let hostname = safe_name (gethostname ()) in
894 let date = sprintf "%04d%02d%02d%02d%02d"
895 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
896 "p2v-" ^ hostname ^ "-" ^ date in
898 (* XXX This code should be made more robust against both network
899 * errors and local I/O errors. Also should allow the user several
900 * attempts to connect, or let them go back to the dialog stage.
903 fun (origin_dev, snapshot_dev, remote_dev) ->
904 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
905 eprintf "sending %s as %s\n%!" origin_dev remote_name;
908 try List.assoc origin_dev all_block_devices
909 with Not_found -> assert false (* internal error *) in
911 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
912 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
914 (* Open the snapshot device. *)
915 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
917 (* Now connect (for SSH) or send the header (for Server/TCP). *)
921 let header = sprintf "p2v2 %s %Ld\n%!" remote_name size in
922 let len = String.length header in
923 assert (len = write sock header 0 len);
924 sock, Pervasives.stdout
926 let cmd = sprintf "ssh -C -p %s %s \"cat > %s/%s\""
927 (quote remote_port) (quote remote_host)
928 (quote remote_directory) (quote remote_name) in
929 let chan = open_process_out cmd in
930 let fd = descr_of_out_channel chan in
934 let bufsize = 1024 * 1024 in
935 let buffer = String.create bufsize in
936 let start = gettimeofday () in
938 let rec copy bytes_sent last_printed_at =
939 let n = read fd buffer 0 bufsize in
941 ignore (write sock buffer 0 n);
943 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
944 let last_printed_at =
945 let now = gettimeofday () in
946 (* Print progress once per second. *)
947 if now -. last_printed_at > 1. then (
948 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
949 let secs_elapsed = now -. start in
950 printf "%.0f%%" (100. *. elapsed);
951 (* After 60 seconds has elapsed, start printing estimates. *)
952 if secs_elapsed >= 60. then (
953 let remaining = 1. -. elapsed in
954 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
955 if secs_remaining > 120. then
956 printf " (about %.0f minutes remaining) "
957 (secs_remaining /. 60.)
959 printf " (about %.0f seconds remaining) "
965 else last_printed_at in
967 copy bytes_sent last_printed_at
972 (* For SSH disconnect, for Server/TCP send a newline. *)
975 ignore (write sock "\n" 0 1)
977 match close_process_out chan with
978 | WEXITED 0 -> () (* OK *)
979 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
980 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
981 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
985 (match transport with
986 | Server | TCP -> close sock
990 (* XXX Write a configuration file. *)
991 let conf_filename = basename ^ ".conf" in
993 (* Clean up and reboot. *)
995 msgbox "virt-p2v completed"
996 (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\nvirsh define %s/%s\n\nWhen you press [OK] this machine will reboot."
997 (Option.default "" state.remote_directory) conf_filename)
1006 eprintf "usage: virt-p2v [ttyname]\n%!";
1009 (* Make sure that exceptions from 'main' get printed out on stdout
1010 * as well as stderr, since stderr is probably redirected to the
1011 * logfile, and so not visible to the user.
1013 let handle_exn f arg =
1015 with exn -> print_endline (Printexc.to_string exn); raise exn
1017 (* If the ISO image has an attachment then it could be a new version
1018 * of virt-p2v.ml (this script). Get the attachment and run it
1019 * instead. Useful mainly for testing, in conjunction with the
1020 * 'make update' target in the virt-p2v Makefile.
1022 let magic = "ISOATTACHMENT002"
1023 let magiclen = String.length magic (* = 16 bytes *)
1024 let trailerlen = magiclen + 8 + 8 (* magic + file start + true size *)
1026 let int64_of_string str =
1028 let add offs shift =
1031 (Int64.shift_left (Int64.of_int (Char.code str.[offs])) shift) !i
1033 add 0 56; add 1 48; add 2 40; add 3 32;
1034 add 4 24; add 5 16; add 6 8; add 7 0;
1037 let update ttyname =
1038 let cdrom = "/dev/cdrom" in
1039 let output = "/tmp/virt-p2v.ml" in
1042 let fd = openfile cdrom [O_RDONLY] 0 in
1043 ignore (LargeFile.lseek fd (Int64.of_int ~-trailerlen) SEEK_END);
1044 let buf = String.create magiclen in
1045 if read fd buf 0 magiclen <> magiclen || buf <> magic then (
1050 (* Read the size. *)
1051 let buf = String.create 8 in
1052 if read fd buf 0 8 <> 8 then
1053 failwith "cannot read attachment offset";
1054 let offset = int64_of_string buf in
1055 let buf = String.create 8 in
1056 if read fd buf 0 8 <> 8 then
1057 failwith "cannot read attachment size";
1058 let size = Int64.to_int (int64_of_string buf) in
1060 (* Seek to beginning of the attachment. *)
1061 ignore (LargeFile.lseek fd offset SEEK_SET);
1063 (* Copy out the attachment. *)
1064 let fd2 = openfile output [O_WRONLY; O_CREAT; O_TRUNC] 0o755 in
1065 let bufsize = 4 * 1024 in
1066 let buffer = String.create bufsize in
1067 let rec copy remaining =
1068 if remaining > 0 then (
1069 let n = min remaining bufsize in
1070 let n = read fd buffer 0 n in
1071 if n = 0 then failwith "corrupted or partial attachment";
1072 ignore (write fd2 buffer 0 n);
1073 copy (remaining - n)
1081 (* Run updated virt-p2v script. *)
1082 execv output [| output; ttyname |]
1084 Unix_error _ | Exit ->
1085 (* Some error, or no attachment, so keep running this script. *)
1086 handle_exn main (Some ttyname)
1088 (* Test harness for the Makefile. The Makefile invokes this script as
1089 * 'virt-p2v.ml --test' just to check it compiles. When it is running
1090 * from the actual live CD, there is a single parameter which is the
1091 * tty name (so usually 'virt-p2v.ml tty1').
1094 match Array.to_list Sys.argv with
1095 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1096 | [ _; "--update"; ttyname ] -> (* Test for update and run. *)
1098 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1099 | [ _; ttyname ] -> (* Run main with ttyname. *)
1100 handle_exn main (Some ttyname)
1101 | [ _ ] -> (* Interactive - no ttyname. *)
1102 handle_exn main None
1105 (* This file must end with a newline *)