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 network : network option;
40 devices_to_send : string list option;
41 root_filesystem : partition option;
42 hypervisor : hypervisor option;
43 architecture : string option;
44 memory : int option; vcpus : int option;
45 mac_address : string option;
47 and network = Auto | Shell
48 and partition = Part of string * string (* eg. "hda", "1" *)
49 | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
50 and hypervisor = Xen | QEMU | KVM
52 (*----------------------------------------------------------------------*)
53 (* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
55 * If left as they are, then this will create a generic virt-p2v script
56 * which asks the user for each question. If you set the defaults here
57 * then you will get a custom virt-p2v which is partially or even fully
58 * automated and won't ask the user any questions.
60 * Note that 'None' means 'no default' (ie. ask the user) whereas
61 * 'Some foo' means use 'foo' as the answer.
64 (* If greeting is true, wait for keypress after boot and during
65 * final verification. Set to 'false' for less interactions.
69 (* Remote host and port. Set to 'Some "host"' and 'Some "port"',
75 (* Remote directory. Set to 'Some "path"' to set up a
76 * directory path, else ask the user.
78 remote_directory = None;
80 (* List of devices to send. Set to 'Some ["sda"; "sdb"]' for
81 * example to select /dev/sda and /dev/sdb.
83 devices_to_send = None;
85 (* The root filesystem containing /etc/fstab. Set to
86 * 'Some (Part ("sda", "3"))' or 'Some (LV ("VolGroup00", "LogVol00"))'
87 * for example, else ask user.
89 root_filesystem = None;
91 (* Network configuration: Set to 'Some Auto' (try to set it up
92 * automatically, or 'Some Shell' (give the user a shell).
96 (* Hypervisor: Set to 'Some Xen', 'Some QEMU' or 'Some KVM'. *)
99 (* Architecture: Set to 'Some "x86_64"' (or another architecture).
100 * If set to 'Some ""' then we try to autodetect the right architecture.
104 (* Memory: Set to 'Some nn' with nn in megabytes. If set to 'Some 0'
105 * then we use same amount of RAM as installed in the physical machine.
109 (* Virtual CPUs: Set to 'Some nn' where nn is the number of virtual CPUs.
110 * If set to 'Some 0' then we use the same as physical CPUs in the
115 (* MAC address: Set to 'Some "aa:bb:cc:dd:ee:ff"' where the string is
116 * the MAC address of the emulated network card. Set to 'Some ""' to
117 * choose a random MAC address.
121 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
122 (*----------------------------------------------------------------------*)
124 (* General helper functions. *)
126 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
127 let xs = List.sort ~cmp xs in
128 let rec loop = function
129 | [] -> [] | [x] -> [x]
130 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
131 | x :: xs -> x :: loop xs
135 let input_all_lines chan =
136 let lines = ref [] in
138 while true do lines := input_line chan :: !lines done; []
140 End_of_file -> List.rev !lines
142 let dev_of_partition = function
143 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
144 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
146 type dialog_status = Yes of string list | No | Help | Back | Error
148 type ask_result = Next of state | Prev | Ask_again
152 * Each function takes some common parameters (eg. ~title) and some
153 * dialog-specific parameters.
155 * Returns the exit status (Yes lines | No | Help | Back | Error).
157 let msgbox, yesno, inputbox, radiolist, checklist =
158 (* Internal function to actually run the "dialog" shell command. *)
159 let run_dialog cparams params =
160 let params = cparams @ params in
161 eprintf "dialog %s\n%!"
162 (String.concat " " (List.map (sprintf "%S") params));
164 (* 'dialog' writes its output/result to stderr, so we need to take
165 * special steps to capture that - in other words, manual pipe/fork.
167 let rfd, wfd = pipe () in
169 | 0 -> (* child, runs dialog *)
171 dup2 wfd stderr; (* capture stderr to pipe *)
172 execvp "dialog" (Array.of_list ("dialog" :: params))
173 | pid -> (* parent *)
175 let chan = in_channel_of_descr rfd in
176 let result = input_all_lines chan in
178 eprintf "dialog result: %S\n%!" (String.concat "\n" result);
179 match snd (wait ()) with
180 | WEXITED 0 -> Yes result (* something selected / entered *)
181 | WEXITED 1 -> No (* cancel / no button *)
182 | WEXITED 2 -> Help (* help pressed *)
183 | WEXITED 3 -> Back (* back button *)
184 | WEXITED _ -> Error (* error or Esc *)
185 | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
186 | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
189 (* Handle the common parameters. Note Continuation Passing Style. *)
190 let with_common cont ?(cancel=false) ?(backbutton=true) title =
191 let params = ["--title"; title] in
192 let params = if not cancel then "--nocancel" :: params else params in
194 if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
199 (* Message box and yes/no box. *)
202 fun cparams text height width ->
204 [ "--msgbox"; text; string_of_int height; string_of_int width ]
208 fun cparams text height width ->
210 [ "--yesno"; text; string_of_int height; string_of_int width ]
213 (* Simple input box. *)
216 fun cparams text height width default ->
218 [ "--inputbox"; text; string_of_int height; string_of_int width;
222 (* Radio list and check list. *)
225 fun cparams text height width listheight items ->
226 let items = List.map (
228 | tag, item, true -> [ tag; item; "on" ]
229 | tag, item, false -> [ tag; item; "off" ]
231 let items = List.concat items in
232 let items = "--single-quoted" ::
233 "--radiolist" :: text ::
234 string_of_int height :: string_of_int width ::
235 string_of_int listheight :: items in
236 run_dialog cparams items
240 fun cparams text height width listheight items ->
241 let items = List.map (
243 | tag, item, true -> [ tag; item; "on" ]
244 | tag, item, false -> [ tag; item; "off" ]
246 let items = List.concat items in
247 let items = "--separate-output" ::
248 "--checklist" :: text ::
249 string_of_int height :: string_of_int width ::
250 string_of_int listheight :: items in
251 run_dialog cparams items
254 msgbox, yesno, inputbox, radiolist, checklist
256 (* Print failure dialog and exit. *)
257 let fail_dialog text =
258 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
259 ignore (msgbox "Error" text 17 50);
262 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
263 let quote = Filename.quote
265 (* Run a shell command and check it returns 0. *)
267 eprintf "sh: %s\n%!" cmd;
268 if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
271 eprintf "shfailok: %s\n%!" cmd;
272 ignore (Sys.command cmd)
274 let shwithstatus cmd =
275 eprintf "shwithstatus: %s\n%!" cmd;
278 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
280 eprintf "shget: %s\n%!" cmd;
281 let chan = open_process_in cmd in
282 let lines = input_all_lines chan in
283 match close_process_in chan with
284 | WEXITED 0 -> Some lines (* command succeeded *)
285 | WEXITED _ -> None (* command failed *)
286 | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
287 | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
289 (* Start an interactive shell. *)
291 shfailok "PS1='\\u@\\h:\\w\\$ ' bash"
293 (* Some true if is dir/file, Some false if not, None if not found. *)
295 try Some ((stat path).st_kind = S_DIR)
296 with Unix_error (ENOENT, "stat", _) -> None
298 try Some ((stat path).st_kind = S_REG)
299 with Unix_error (ENOENT, "stat", _) -> None
301 (* Useful regular expression. *)
302 let whitespace = Pcre.regexp "[ \t]+"
304 (* Generate a predictable safe name containing only letters, numbers
305 * and underscores. If passed a string with no letters or numbers,
306 * generates "_1", "_2", etc.
311 fun () -> incr i; "_" ^ string_of_int !i
314 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
315 let name = String.copy name in
316 let have_safe = ref false in
317 for i = 0 to String.length name - 1 do
318 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
320 if !have_safe then name else next_anon ()
322 type block_device = string * int64 (* "hda" & size in bytes *)
324 (* Parse the output of 'lvs' to get list of LV names, sizes,
325 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
328 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
332 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
336 let lines = List.map (Pcre.split ~rex:whitespace) lines in
339 | [vg; lv; pvs; lvsize]
340 | [_; vg; lv; pvs; lvsize] ->
341 let pvs = String.nsplit pvs "," in
342 let pvs = List.filter_map (
345 let subs = Pcre.exec ~rex:devname pv in
346 Some (Pcre.get_substring subs 1)
349 eprintf "lvs: unexpected device name: %s\n%!" pv;
352 LV (vg, lv), pvs, lvsize
354 failwith ("lvs: unexpected output: " ^ String.concat "," line)
357 (* Get the partitions on a block device.
358 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
360 let get_partitions dev =
361 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
362 let devdir = "/sys/block/" ^ dev in
363 let parts = Sys.readdir devdir in
364 let parts = Array.to_list parts in
365 let parts = List.filter (
366 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
368 let parts = List.filter_map (
371 let subs = Pcre.exec ~rex part in
372 Some (Part (dev, Pcre.get_substring subs 1))
378 (* Generate snapshot device name from device name. *)
379 let snapshot_name dev =
380 "snap" ^ (safe_name dev)
382 (* Perform a device-mapper snapshot with ramdisk overlay. *)
384 let next_free_ram_disk =
386 fun () -> incr i; "/dev/ram" ^ string_of_int !i
388 fun origin_dev snapshot_dev ->
389 let ramdisk = next_free_ram_disk () in
391 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
392 let lines = shget cmd in
394 | Some (sectors::_) -> Int64.of_string sectors
396 fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
398 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
399 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
400 snapshot_dev sectors origin_dev);
401 (* Create the snapshot. *)
402 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
403 snapshot_dev sectors snapshot_dev ramdisk)
405 (* Try to perform automatic network configuration, assuming a Fedora or RHEL-
406 * like root filesystem mounted on /mnt/root.
408 let auto_network state =
409 (* Fedora gives an error if this file doesn't exist. *)
410 sh "touch /etc/resolv.conf";
412 chdir "/etc/sysconfig";
414 sh "mv network network.saved";
415 sh "mv networking networking.saved";
416 sh "mv network-scripts network-scripts.saved";
418 (* Originally I symlinked these, but that causes dhclient to
419 * keep open /mnt/root (as its cwd is in network-scripts subdir).
420 * So now we will copy them recursively instead.
422 sh "cp -r /mnt/root/etc/sysconfig/network .";
423 sh "cp -r /mnt/root/etc/sysconfig/networking .";
424 sh "cp -r /mnt/root/etc/sysconfig/network-scripts .";
426 let status = shwithstatus "/etc/init.d/network start" in
428 sh "rm -rf network networking network-scripts";
429 sh "mv network.saved network";
430 sh "mv networking.saved networking";
431 sh "mv network-scripts.saved network-scripts";
435 (* Try to ping the remote host to see if this worked. *)
436 shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
438 if state.greeting then (
439 printf "\n\nDid automatic network configuration work?\n";
440 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
442 let line = read_line () in
443 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
446 (* Non-interactive: return the status of /etc/init.d/network start. *)
449 (* Map local device names to remote devices names. At the moment we
450 * just change sd* to hd* (as device names appear under fullvirt). In
451 * future, lots of complex possibilities.
453 let remote_of_origin_dev =
454 let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
455 let devsd_subst = Pcre.subst "hd$1" in
457 Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
459 (* Rewrite /mnt/root/etc/fstab. *)
460 let rewrite_fstab state devices_to_send =
461 let filename = "/mnt/root/etc/fstab" in
462 if is_file filename = Some true then (
463 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
465 let chan = open_in filename in
466 let lines = input_all_lines chan in
468 let lines = List.map (Pcre.split ~rex:whitespace) lines in
469 let lines = List.map (
471 | dev :: rest when String.starts_with dev "/dev/" ->
472 let dev = String.sub dev 5 (String.length dev - 5) in
473 let dev = remote_of_origin_dev dev in
474 let dev = "/dev/" ^ dev in
479 let chan = open_out filename in
482 | [dev; mountpoint; fstype; options; freq; passno] ->
483 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
484 dev mountpoint fstype options freq passno
486 output_string chan (String.concat " " line)
491 (* Main entry point. *)
492 let rec main ttyname =
493 (* Running from an init script. We don't have much of a
494 * login environment, so set one up.
498 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
499 "/usr/bin"; "/bin"]);
500 putenv "HOME" "/root";
501 putenv "LOGNAME" "root";
503 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
506 (* Set up logging to /tmp/virt-p2v.log. *)
507 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
511 (* Log the start up time. *)
512 eprintf "\n\n**************************************************\n\n";
513 let tm = localtime (time ()) in
514 eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
515 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
517 (* Connect stdin/stdout to the tty. *)
521 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
525 printf "virt-p2v.ml starting up ...\n%!";
527 (* Search for all non-removable block devices. Do this early and bail
528 * if we can't find anything. This is a list of strings, like "hda".
530 let all_block_devices : block_device list =
531 let rex = Pcre.regexp "^[hs]d" in
532 let devices = Array.to_list (Sys.readdir "/sys/block") in
533 let devices = List.sort devices in
534 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
535 eprintf "all_block_devices: block devices: %s\n%!"
536 (String.concat "; " devices);
537 (* Run blockdev --getsize64 on each, and reject any where this fails
538 * (probably removable devices).
540 let devices = List.filter_map (
542 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
543 let lines = shget cmd in
545 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
546 | Some [] | None -> None
548 eprintf "all_block_devices: non-removable block devices: %s\n%!"
550 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
552 fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
555 (* Search for partitions and LVs (anything that could contain a
556 * filesystem directly). We refer to these generically as
559 let all_partitions : partition list =
562 let lvs = get_lvs () in
563 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
564 let pvs = List.concat pvs in
565 let pvs = sort_uniq pvs in
566 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
567 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
568 eprintf "all_partitions: LVs: %s\n%!"
569 (String.concat "; " (List.map dev_of_partition lvs));
572 (* Partitions (eg. "sda1", "sda2"). *)
574 let parts = List.map fst all_block_devices in
575 let parts = List.map get_partitions parts in
576 let parts = List.concat parts in
577 eprintf "all_partitions: all partitions: %s\n%!"
578 (String.concat "; " (List.map dev_of_partition parts));
580 (* Remove any partitions which are PVs. *)
581 let parts = List.filter (
583 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
584 | LV _ -> assert false
587 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
588 (String.concat "; " (List.map dev_of_partition parts));
590 (* Concatenate LVs & Parts *)
594 let ask_greeting state =
595 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);
599 let ask_hostname state =
601 inputbox "Remote host" "Remote host" 10 50
602 (Option.default "" state.remote_host)
604 | Yes [] -> Ask_again
605 | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
606 | No | Help | Error -> Ask_again
612 inputbox "Remote port" "Remote port" 10 50
613 (Option.default "" state.remote_port)
615 | Yes ([]|""::_) -> Next { state with remote_port = Some "22" }
616 | Yes (port::_) -> Next { state with remote_port = Some port }
617 | No | Help | Error -> Ask_again
621 let ask_directory state =
623 inputbox "Remote directory" "Remote directory" 10 50
624 (Option.default "" state.remote_directory)
627 Next { state with remote_directory = Some "/var/lib/xen/images" }
628 | Yes (dir::_) -> Next { state with remote_directory = Some dir }
629 | No | Help | Error -> Ask_again
633 let ask_network state =
635 radiolist "Network configuration" "Network configuration" 10 50 2 [
636 "auto", "Automatic configuration", state.network = Some Auto;
637 "sh", "Configure from the shell", state.network = Some Shell;
640 | Yes ("auto"::_) -> Next { state with network = Some Auto }
641 | Yes ("sh"::_) -> Next { state with network = Some Shell }
642 | Yes _ | No | Help | Error -> Ask_again
646 let ask_devices state =
647 let selected_devices = Option.default [] state.devices_to_send in
648 let devices = List.map (
649 fun (dev, blksize) ->
651 sprintf "/dev/%s (%.3f GB)" dev
652 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
653 List.mem dev selected_devices)
654 ) all_block_devices in
656 checklist "Devices" "Pick devices to send" 15 50 8 devices
658 | Yes [] | No | Help | Error -> Ask_again
659 | Yes devices -> Next { state with devices_to_send = Some devices }
664 let parts = List.mapi (
666 (string_of_int i, dev_of_partition part,
667 Some part = state.root_filesystem)
670 radiolist "Root device"
671 "Pick partition containing the root (/) filesystem" 15 50 6
675 let part = List.nth all_partitions (int_of_string i) in
676 Next { state with root_filesystem = Some part }
677 | Yes [] | No | Help | Error -> Ask_again
681 let ask_hypervisor state =
683 radiolist "Hypervisor"
684 "Choose hypervisor / virtualization system"
686 "xen", "Xen", state.hypervisor = Some Xen;
687 "qemu", "QEMU", state.hypervisor = Some QEMU;
688 "kvm", "KVM", state.hypervisor = Some KVM;
689 "other", "Other", state.hypervisor = None
692 | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
693 | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
694 | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
695 | Yes _ -> Next { state with hypervisor = None }
696 | No | Help | Error -> Ask_again
700 let ask_architecture state =
702 radiolist "Architecture" "Machine architecture" 16 50 8 [
703 "i386", "i386 and up (32 bit)", state.architecture = Some "i386";
704 "x86_64", "x86-64 (64 bit)", state.architecture = Some "x86_64";
705 "ia64", "Itanium IA64", state.architecture = Some "ia64";
706 "ppc", "PowerPC (32 bit)", state.architecture = Some "ppc";
707 "ppc64", "PowerPC (64 bit)", state.architecture = Some "ppc64";
708 "sparc", "SPARC (32 bit)", state.architecture = Some "sparc";
709 "sparc64", "SPARC (64 bit)", state.architecture = Some "sparc64";
710 (* "auto", "Other or auto-detect",
711 state.architecture = None || state.architecture = Some "";*)
714 | Yes (("auto"|"")::_ | []) -> Next { state with architecture = Some "" }
715 | Yes (arch :: _) -> Next { state with architecture = Some arch }
716 | No | Help | Error -> Ask_again
720 let ask_memory state =
722 inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
724 (Option.map_default string_of_int "" state.memory)
726 | Yes (""::_ | []) -> Next { state with memory = Some 0 }
728 let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
729 if mem < 0 || (mem > 0 && mem < 64) then Ask_again
730 else Next { state with memory = Some mem }
731 | No | Help | Error -> Ask_again
735 let ask_vcpus state =
737 inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
739 (Option.map_default string_of_int "" state.vcpus)
741 | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
744 try int_of_string vcpus with Failure "int_of_string" -> -1 in
745 if vcpus < 0 then Ask_again
746 else Next { state with vcpus = Some vcpus }
747 | No | Help | Error -> Ask_again
751 let ask_mac_address state =
753 inputbox "MAC address"
754 "Network MAC address. Leave blank to use a random address." 10 50
755 (Option.default "" state.mac_address)
757 | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
758 | Yes (mac :: _) -> Next { state with mac_address = Some mac }
759 | No | Help | Error -> Ask_again
763 let ask_verify state =
765 yesno "Verify and proceed"
766 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
778 (Option.default "" state.remote_host)
779 (Option.default "" state.remote_port)
780 (Option.default "" state.remote_directory)
781 (match state.network with
782 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
784 (String.concat "," (Option.default [] state.devices_to_send))
785 (Option.map_default dev_of_partition "" state.root_filesystem)
786 (match state.hypervisor with
787 | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
788 | None -> "Other / not set")
789 (match state.architecture with
790 | Some "" -> "Guess" | Some arch -> arch | None -> "")
791 (match state.memory with
792 | Some 0 -> "Same as physical"
793 | Some mem -> string_of_int mem ^ " MB" | None -> "")
794 (match state.vcpus with
795 | Some 0 -> "Same as physical"
796 | Some vcpus -> string_of_int vcpus | None -> "")
797 (match state.mac_address with
798 | Some "" -> "Random" | Some mac -> mac | None -> "")
802 | Yes _ -> Next state
804 | No | Help | Error -> Ask_again
807 (* This is the list of dialogs, in order. The user can go forwards or
808 * backwards through them. The second parameter in each pair is
809 * false if we need to skip this dialog (info already supplied in
813 ask_greeting, (* Initial greeting. *)
815 ask_hostname, (* Hostname. *)
816 defaults.remote_host = None;
817 ask_port, (* Port number. *)
818 defaults.remote_port = None;
819 ask_directory, (* Remote directory. *)
820 defaults.remote_directory = None;
821 ask_network, (* Network configuration. *)
822 defaults.network = None;
823 ask_devices, (* Block devices to send. *)
824 defaults.devices_to_send = None;
825 ask_root, (* Root filesystem. *)
826 defaults.root_filesystem = None;
827 ask_hypervisor, (* Hypervisor. *)
828 defaults.hypervisor = None;
829 ask_architecture, (* Architecture. *)
830 defaults.architecture = None;
831 ask_memory, (* Memory. *)
832 defaults.memory = None;
833 ask_vcpus, (* VCPUs. *)
834 defaults.vcpus = None;
835 ask_mac_address, (* MAC address. *)
836 defaults.mac_address = None;
837 ask_verify, (* Verify settings. *)
841 (* Loop through the dialogs until we reach the end. *)
842 let rec loop posn state =
843 eprintf "dialog loop: posn = %d\n%!" posn;
844 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
846 let dlg, no_skip = dlgs.(posn) in
847 let skip = not no_skip in
849 (* Skip this dialog and move straight to the next one. *)
854 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
855 | Prev -> loop (posn-1) state (* Backwards / back button. *)
856 | Ask_again -> loop posn state (* Repeat the question. *)
860 let state = loop 0 defaults in
862 eprintf "finished dialog loop\n%!";
864 (* Check that the environment is a sane-looking live CD. If not, bail. *)
865 if is_dir "/mnt/root" <> Some true then
866 fail_dialog "You should only run this script from the live CD or a USB key.";
868 (* Switch LVM config. *)
870 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
871 sh "rm -f /etc/lvm/cache/.cache";
872 sh "rm -f /etc/lvm.new/cache/.cache";
874 (* Snapshot the block devices to send. *)
875 let devices_to_send = Option.get state.devices_to_send in
876 let devices_to_send =
879 let snapshot_dev = snapshot_name origin_dev in
880 snapshot origin_dev snapshot_dev;
881 (origin_dev, snapshot_dev)
884 (* Run kpartx on the snapshots. *)
886 fun (origin, snapshot) ->
887 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
890 (* Rescan for LVs. *)
894 (* Mount the root filesystem under /mnt/root. *)
895 let root_filesystem = Option.get state.root_filesystem in
896 (match root_filesystem with
897 | Part (dev, partnum) ->
898 let dev = dev ^ partnum in
899 let snapshot_dev = snapshot_name dev in
900 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
903 (* The LV will be backed by a snapshot device, so just mount
906 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
909 (* See if we can do network configuration. *)
910 let network = Option.get state.network in
913 printf "Network configuration.\n\n";
914 printf "Please configure the network from this shell.\n\n";
915 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
920 "Trying network auto-configuration from root filesystem ...\n\n%!";
921 if not (auto_network state) then (
922 printf "\nAuto-configuration failed. Starting a shell.\n\n";
923 printf "Please configure the network from this shell.\n\n";
924 printf "When you have finished, exit the shell with ^D or exit.\n\n";
929 (* Work out what devices will be called at the remote end. *)
930 let devices_to_send = List.map (
931 fun (origin_dev, snapshot_dev) ->
932 let remote_dev = remote_of_origin_dev origin_dev in
933 (origin_dev, snapshot_dev, remote_dev)
936 (* Modify files on the root filesystem. *)
937 rewrite_fstab state devices_to_send;
938 (* XXX Other files to rewrite? *)
940 (* XXX Autodetect architecture of root filesystem by looking for /bin/ls. *)
941 let system_architecture = "x86_64" in
943 (* XXX Autodetect system memory. *)
944 let system_memory = 256 in
946 (* XXX Autodetect system # pCPUs. *)
947 let system_nr_cpus = 1 in
949 (* Unmount the root filesystem and sync disks. *)
950 sh "umount /mnt/root";
951 sh "sync"; (* Ugh, should be in stdlib. *)
953 (* Disable screen blanking on console. *)
954 sh "setterm -blank 0";
956 let remote_host = Option.get state.remote_host in
957 let remote_port = Option.get state.remote_port in
958 let remote_directory = Option.get state.remote_directory in
960 (* Functions to connect and disconnect from the remote system. *)
961 let do_connect remote_name _ =
962 let cmd = sprintf "ssh -C -p %s %s \"cat > %s/%s\""
963 (quote remote_port) (quote remote_host)
964 (quote remote_directory) (quote remote_name) in
965 eprintf "connect: %s\n%!" cmd;
966 let chan = open_process_out cmd in
967 descr_of_out_channel chan, chan
969 let do_disconnect (_, chan) =
970 match close_process_out chan with
971 | WEXITED 0 -> () (* OK *)
972 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
973 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
974 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
977 (* XXX This is using the hostname derived from network configuration
978 * above. We might want to ask the user to choose.
980 let hostname = safe_name (gethostname ()) in
982 let date = sprintf "%04d%02d%02d%02d%02d"
983 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
984 "p2v-" ^ hostname ^ "-" ^ date in
986 (* Work out what the image filenames will be at the remote end. *)
987 let devices_to_send = List.map (
988 fun (origin_dev, snapshot_dev, remote_dev) ->
989 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
990 (origin_dev, snapshot_dev, remote_dev, remote_name)
993 (* Write a configuration file. Not sure if this is any better than
994 * just 'sprintf-ing' bits of XML text together, but at least we will
995 * always get well-formed XML.
997 * XXX For some of the stuff here we really should do a
998 * virConnectGetCapabilities call to the remote host first.
1000 * XXX There is a case for using virt-install to generate this XML.
1001 * When we start to incorporate libvirt access & storage API this
1002 * needs to be rethought.
1004 let conf_filename = basename ^ ".conf" in
1007 match state.architecture with
1008 | Some "" | None -> system_architecture
1009 | Some arch -> arch in
1011 match state.memory with
1012 | Some 0 | None -> system_memory
1013 | Some memory -> memory in
1015 match state.vcpus with
1016 | Some 0 | None -> system_nr_cpus
1019 match state.mac_address with
1022 List.map (sprintf "%02x") (
1023 List.map (fun _ -> Random.int 256) [0;0;0]
1025 String.concat ":" ("00"::"16"::"3e"::random)
1026 | Some mac -> mac in
1029 (* Shortcut to make "<name>value</name>". *)
1030 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1031 (* ... and the _other_ sort of leaf (god I hate XML). *)
1032 let tleaf name attribs = Xml.Element (name, attribs, []) in
1034 (* Standard stuff for every domain. *)
1035 let name = leaf "name" hostname in
1036 let memory = leaf "memory" (string_of_int (memory * 1024)) in
1037 let vcpu = leaf "vcpu" (string_of_int vcpus) in
1039 (* Top-level stuff which differs for each HV type (isn't this supposed
1040 * to be portable ...)
1043 match state.hypervisor with
1045 [Xml.Element ("os", [],
1047 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1048 tleaf "boot" ["dev", "hd"]]);
1049 Xml.Element ("features", [],
1053 tleaf "clock" ["sync", "localtime"]]
1055 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1056 tleaf "clock" ["sync", "localtime"]]
1058 [Xml.Element ("os", [],
1059 [Xml.Element ("type", ["arch",architecture;
1061 [Xml.PCData "hvm"]);
1062 tleaf "boot" ["dev", "hd"]])]
1066 (* <devices> section. *)
1069 match state.hypervisor with
1071 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1073 [leaf "emulator" "/usr/bin/qemu"]
1075 [leaf "emulator" "/usr/bin/qemu-kvm"]
1079 Xml.Element ("interface", ["type", "user"],
1080 [tleaf "mac" ["address", mac_address]]) in
1081 (* XXX should have an option for Xen bridging:
1083 "interface", ["type","bridge"],
1084 [tleaf "source" ["bridge","xenbr0"];
1085 tleaf "mac" ["address",mac_address];
1086 tleaf "script" ["path","vif-bridge"]])*)
1087 let graphics = tleaf "graphics" ["type", "vnc"] in
1089 let disks = List.map (
1090 fun (_, _, remote_dev, remote_name) ->
1092 "disk", ["type", "file";
1094 [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1095 tleaf "target" ["dev", remote_dev]]
1097 ) devices_to_send in
1101 emulator @ interface :: graphics :: disks
1104 (* Put it all together in <domain type='foo'>. *)
1107 (match state.hypervisor with
1108 | Some Xen -> ["type", "xen"]
1109 | Some QEMU -> ["type", "qemu"]
1110 | Some KVM -> ["type", "kvm"]
1112 name :: memory :: vcpu :: extras @ [devices]
1115 let xml = Xml.to_string_fmt xml in
1116 let xml_len = String.length xml in
1117 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1119 let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1120 (* In OCaml this actually loops calling write(2) *)
1121 ignore (write sock xml 0 xml_len);
1124 (* Send the device snapshots to the remote host. *)
1125 (* XXX This code should be made more robust against both network
1126 * errors and local I/O errors. Also should allow the user several
1127 * attempts to connect, or let them go back to the dialog stage.
1130 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1131 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1134 try List.assoc origin_dev all_block_devices
1135 with Not_found -> assert false (* internal error *) in
1137 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1138 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1140 (* Open the snapshot device. *)
1141 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1144 let (sock,_) as conn = do_connect remote_name size in
1146 (* Copy the data. *)
1147 let bufsize = 1024 * 1024 in
1148 let buffer = String.create bufsize in
1149 let start = gettimeofday () in
1151 let rec copy bytes_sent last_printed_at =
1152 let n = read fd buffer 0 bufsize in
1154 ignore (write sock buffer 0 n);
1156 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1157 let last_printed_at =
1158 let now = gettimeofday () in
1159 (* Print progress once per second. *)
1160 if now -. last_printed_at > 1. then (
1161 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1162 let secs_elapsed = now -. start in
1163 printf "%.0f%%" (100. *. elapsed);
1164 (* After 60 seconds has elapsed, start printing estimates. *)
1165 if secs_elapsed >= 60. then (
1166 let remaining = 1. -. elapsed in
1167 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1168 if secs_remaining > 120. then
1169 printf " (about %.0f minutes remaining) "
1170 (secs_remaining /. 60.)
1172 printf " (about %.0f seconds remaining) "
1178 else last_printed_at in
1180 copy bytes_sent last_printed_at
1189 (* Clean up and reboot. *)
1191 msgbox "virt-p2v completed"
1192 (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."
1193 remote_directory conf_filename)
1202 eprintf "usage: virt-p2v [ttyname]\n%!";
1205 (* Make sure that exceptions from 'main' get printed out on stdout
1206 * as well as stderr, since stderr is probably redirected to the
1207 * logfile, and so not visible to the user.
1209 let handle_exn f arg =
1211 with exn -> print_endline (Printexc.to_string exn); raise exn
1213 (* If the ISO image has an attachment then it could be a new version
1214 * of virt-p2v.ml (this script). Get the attachment and run it
1215 * instead. Useful mainly for testing, in conjunction with the
1216 * 'make update' target in the virt-p2v Makefile.
1218 let magic = "ISOATTACHMENT002"
1219 let magiclen = String.length magic (* = 16 bytes *)
1220 let trailerlen = magiclen + 8 + 8 (* magic + file start + true size *)
1222 let int64_of_string str =
1224 let add offs shift =
1227 (Int64.shift_left (Int64.of_int (Char.code str.[offs])) shift) !i
1229 add 0 56; add 1 48; add 2 40; add 3 32;
1230 add 4 24; add 5 16; add 6 8; add 7 0;
1233 let update ttyname =
1234 let cdrom = "/dev/cdrom" in
1235 let output = "/tmp/virt-p2v.ml" in
1238 let fd = openfile cdrom [O_RDONLY] 0 in
1239 ignore (LargeFile.lseek fd (Int64.of_int ~-trailerlen) SEEK_END);
1240 let buf = String.create magiclen in
1241 if read fd buf 0 magiclen <> magiclen || buf <> magic then (
1246 (* Read the size. *)
1247 let buf = String.create 8 in
1248 if read fd buf 0 8 <> 8 then
1249 failwith "cannot read attachment offset";
1250 let offset = int64_of_string buf in
1251 let buf = String.create 8 in
1252 if read fd buf 0 8 <> 8 then
1253 failwith "cannot read attachment size";
1254 let size = Int64.to_int (int64_of_string buf) in
1256 (* Seek to beginning of the attachment. *)
1257 ignore (LargeFile.lseek fd offset SEEK_SET);
1259 (* Copy out the attachment. *)
1260 let fd2 = openfile output [O_WRONLY; O_CREAT; O_TRUNC] 0o755 in
1261 let bufsize = 4 * 1024 in
1262 let buffer = String.create bufsize in
1263 let rec copy remaining =
1264 if remaining > 0 then (
1265 let n = min remaining bufsize in
1266 let n = read fd buffer 0 n in
1267 if n = 0 then failwith "corrupted or partial attachment";
1268 ignore (write fd2 buffer 0 n);
1269 copy (remaining - n)
1277 (* Run updated virt-p2v script. *)
1278 execv output [| output; ttyname |]
1280 Unix_error _ | Exit ->
1281 (* Some error, or no attachment, so keep running this script. *)
1282 handle_exn main (Some ttyname)
1284 (* Test harness for the Makefile. The Makefile invokes this script as
1285 * 'virt-p2v.ml --test' just to check it compiles. When it is running
1286 * from the actual live CD, there is a single parameter which is the
1287 * tty name (so usually 'virt-p2v.ml tty1').
1290 match Array.to_list Sys.argv with
1291 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1292 | [ _; "--update"; ttyname ] -> (* Test for update and run. *)
1294 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1295 | [ _; ttyname ] -> (* Run main with ttyname. *)
1296 handle_exn main (Some ttyname)
1297 | [ _ ] -> (* Interactive - no ttyname. *)
1298 handle_exn main None
1301 (* This file must end with a newline *)