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 transport : transport option;
39 remote_directory : string option;
40 network : network option;
41 devices_to_send : string list option;
42 root_filesystem : partition option;
43 hypervisor : hypervisor option;
44 architecture : string option;
45 memory : int option; vcpus : int option;
46 mac_address : string option;
48 and transport = Server | SSH
49 and network = Auto | Shell
50 and partition = Part of string * string (* eg. "hda", "1" *)
51 | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
52 and hypervisor = Xen | QEMU | KVM
54 (*----------------------------------------------------------------------*)
55 (* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
57 * If left as they are, then this will create a generic virt-p2v script
58 * which asks the user for each question. If you set the defaults here
59 * then you will get a custom virt-p2v which is partially or even fully
60 * automated and won't ask the user any questions.
62 * Note that 'None' means 'no default' (ie. ask the user) whereas
63 * 'Some foo' means use 'foo' as the answer.
66 (* If greeting is true, wait for keypress after boot and during
67 * final verification. Set to 'false' for less interactions.
71 (* Transport: Set to 'Some Server' or 'Some SSH' to assume Server or SSH
72 * transports respectively.
76 (* Remote host and port. Set to 'Some "host"' and 'Some "port"',
82 (* Remote directory (only for SSH transport). Set to 'Some "path"'
83 * to set up a directory path, else ask the user.
85 remote_directory = None;
87 (* List of devices to send. Set to 'Some ["sda"; "sdb"]' for
88 * example to select /dev/sda and /dev/sdb.
90 devices_to_send = None;
92 (* The root filesystem containing /etc/fstab. Set to
93 * 'Some (Part ("sda", "3"))' or 'Some (LV ("VolGroup00", "LogVol00"))'
94 * for example, else ask user.
96 root_filesystem = None;
98 (* Network configuration: Set to 'Some Auto' (try to set it up
99 * automatically, or 'Some Shell' (give the user a shell).
103 (* Hypervisor: Set to 'Some Xen', 'Some QEMU' or 'Some KVM'. *)
106 (* Architecture: Set to 'Some "x86_64"' (or another architecture).
107 * If set to 'Some ""' then we try to autodetect the right architecture.
111 (* Memory: Set to 'Some nn' with nn in megabytes. If set to 'Some 0'
112 * then we use same amount of RAM as installed in the physical machine.
116 (* Virtual CPUs: Set to 'Some nn' where nn is the number of virtual CPUs.
117 * If set to 'Some 0' then we use the same as physical CPUs in the
122 (* MAC address: Set to 'Some "aa:bb:cc:dd:ee:ff"' where the string is
123 * the MAC address of the emulated network card. Set to 'Some ""' to
124 * choose a random MAC address.
128 (* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
129 (*----------------------------------------------------------------------*)
131 (* General helper functions. *)
133 let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
134 let xs = List.sort ~cmp xs in
135 let rec loop = function
136 | [] -> [] | [x] -> [x]
137 | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
138 | x :: xs -> x :: loop xs
142 let input_all_lines chan =
143 let lines = ref [] in
145 while true do lines := input_line chan :: !lines done; []
147 End_of_file -> List.rev !lines
149 let dev_of_partition = function
150 | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
151 | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
153 type dialog_status = Yes of string list | No | Help | Back | Error
155 type ask_result = Next of state | Prev | Ask_again
159 * Each function takes some common parameters (eg. ~title) and some
160 * dialog-specific parameters.
162 * Returns the exit status (Yes lines | No | Help | Back | Error).
164 let msgbox, yesno, inputbox, radiolist, checklist =
165 (* Internal function to actually run the "dialog" shell command. *)
166 let run_dialog cparams params =
167 let params = cparams @ params in
168 eprintf "dialog %s\n%!"
169 (String.concat " " (List.map (sprintf "%S") params));
171 (* 'dialog' writes its output/result to stderr, so we need to take
172 * special steps to capture that - in other words, manual pipe/fork.
174 let rfd, wfd = pipe () in
176 | 0 -> (* child, runs dialog *)
178 dup2 wfd stderr; (* capture stderr to pipe *)
179 execvp "dialog" (Array.of_list ("dialog" :: params))
180 | pid -> (* parent *)
182 let chan = in_channel_of_descr rfd in
183 let result = input_all_lines chan in
185 eprintf "dialog result: %S\n%!" (String.concat "\n" result);
186 match snd (wait ()) with
187 | WEXITED 0 -> Yes result (* something selected / entered *)
188 | WEXITED 1 -> No (* cancel / no button *)
189 | WEXITED 2 -> Help (* help pressed *)
190 | WEXITED 3 -> Back (* back button *)
191 | WEXITED _ -> Error (* error or Esc *)
192 | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
193 | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
196 (* Handle the common parameters. Note Continuation Passing Style. *)
197 let with_common cont ?(cancel=false) ?(backbutton=true) title =
198 let params = ["--title"; title] in
199 let params = if not cancel then "--nocancel" :: params else params in
201 if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
206 (* Message box and yes/no box. *)
209 fun cparams text height width ->
211 [ "--msgbox"; text; string_of_int height; string_of_int width ]
215 fun cparams text height width ->
217 [ "--yesno"; text; string_of_int height; string_of_int width ]
220 (* Simple input box. *)
223 fun cparams text height width default ->
225 [ "--inputbox"; text; string_of_int height; string_of_int width;
229 (* Radio list and check list. *)
232 fun cparams text height width listheight items ->
233 let items = List.map (
235 | tag, item, true -> [ tag; item; "on" ]
236 | tag, item, false -> [ tag; item; "off" ]
238 let items = List.concat items in
239 let items = "--single-quoted" ::
240 "--radiolist" :: text ::
241 string_of_int height :: string_of_int width ::
242 string_of_int listheight :: items in
243 run_dialog cparams items
247 fun cparams text height width listheight items ->
248 let items = List.map (
250 | tag, item, true -> [ tag; item; "on" ]
251 | tag, item, false -> [ tag; item; "off" ]
253 let items = List.concat items in
254 let items = "--separate-output" ::
255 "--checklist" :: text ::
256 string_of_int height :: string_of_int width ::
257 string_of_int listheight :: items in
258 run_dialog cparams items
261 msgbox, yesno, inputbox, radiolist, checklist
263 (* Print failure dialog and exit. *)
264 let fail_dialog text =
265 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
266 ignore (msgbox "Error" text 17 50);
269 (* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
270 let quote = Filename.quote
272 (* Run a shell command and check it returns 0. *)
274 eprintf "sh: %s\n%!" cmd;
275 if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
278 eprintf "shfailok: %s\n%!" cmd;
279 ignore (Sys.command cmd)
281 let shwithstatus cmd =
282 eprintf "shwithstatus: %s\n%!" cmd;
285 (* Same as `cmd` in shell. Any error message will be in the logfile. *)
287 eprintf "shget: %s\n%!" cmd;
288 let chan = open_process_in cmd in
289 let lines = input_all_lines chan in
290 match close_process_in chan with
291 | WEXITED 0 -> Some lines (* command succeeded *)
292 | WEXITED _ -> None (* command failed *)
293 | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
294 | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
296 (* Start an interactive shell. *)
298 shfailok "PS1='\\u@\\h:\\w\\$ ' bash"
300 (* Some true if is dir/file, Some false if not, None if not found. *)
302 try Some ((stat path).st_kind = S_DIR)
303 with Unix_error (ENOENT, "stat", _) -> None
305 try Some ((stat path).st_kind = S_REG)
306 with Unix_error (ENOENT, "stat", _) -> None
308 (* Useful regular expression. *)
309 let whitespace = Pcre.regexp "[ \t]+"
311 (* Generate a predictable safe name containing only letters, numbers
312 * and underscores. If passed a string with no letters or numbers,
313 * generates "_1", "_2", etc.
318 fun () -> incr i; "_" ^ string_of_int !i
321 let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
322 let name = String.copy name in
323 let have_safe = ref false in
324 for i = 0 to String.length name - 1 do
325 if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
327 if !have_safe then name else next_anon ()
329 type block_device = string * int64 (* "hda" & size in bytes *)
331 (* Parse the output of 'lvs' to get list of LV names, sizes,
332 * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
335 let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
339 shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
343 let lines = List.map (Pcre.split ~rex:whitespace) lines in
346 | [vg; lv; pvs; lvsize]
347 | [_; vg; lv; pvs; lvsize] ->
348 let pvs = String.nsplit pvs "," in
349 let pvs = List.filter_map (
352 let subs = Pcre.exec ~rex:devname pv in
353 Some (Pcre.get_substring subs 1)
356 eprintf "lvs: unexpected device name: %s\n%!" pv;
359 LV (vg, lv), pvs, lvsize
361 failwith ("lvs: unexpected output: " ^ String.concat "," line)
364 (* Get the partitions on a block device.
365 * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
367 let get_partitions dev =
368 let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
369 let devdir = "/sys/block/" ^ dev in
370 let parts = Sys.readdir devdir in
371 let parts = Array.to_list parts in
372 let parts = List.filter (
373 fun name -> Some true = is_dir (devdir ^ "/" ^ name)
375 let parts = List.filter_map (
378 let subs = Pcre.exec ~rex part in
379 Some (Part (dev, Pcre.get_substring subs 1))
385 (* Generate snapshot device name from device name. *)
386 let snapshot_name dev =
387 "snap" ^ (safe_name dev)
389 (* Perform a device-mapper snapshot with ramdisk overlay. *)
391 let next_free_ram_disk =
393 fun () -> incr i; "/dev/ram" ^ string_of_int !i
395 fun origin_dev snapshot_dev ->
396 let ramdisk = next_free_ram_disk () in
398 let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
399 let lines = shget cmd in
401 | Some (sectors::_) -> Int64.of_string sectors
403 fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
405 (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
406 sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
407 snapshot_dev sectors origin_dev);
408 (* Create the snapshot. *)
409 sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
410 snapshot_dev sectors snapshot_dev ramdisk)
412 (* Try to perform automatic network configuration, assuming a Fedora or RHEL-
413 * like root filesystem mounted on /mnt/root.
415 let auto_network state =
416 (* Fedora gives an error if this file doesn't exist. *)
417 sh "touch /etc/resolv.conf";
419 chdir "/etc/sysconfig";
421 sh "mv network network.saved";
422 sh "mv networking networking.saved";
423 sh "mv network-scripts network-scripts.saved";
425 (* Originally I symlinked these, but that causes dhclient to
426 * keep open /mnt/root (as its cwd is in network-scripts subdir).
427 * So now we will copy them recursively instead.
429 sh "cp -r /mnt/root/etc/sysconfig/network .";
430 sh "cp -r /mnt/root/etc/sysconfig/networking .";
431 sh "cp -r /mnt/root/etc/sysconfig/network-scripts .";
433 let status = shwithstatus "/etc/init.d/network start" in
435 sh "rm -rf network networking network-scripts";
436 sh "mv network.saved network";
437 sh "mv networking.saved networking";
438 sh "mv network-scripts.saved network-scripts";
442 (* Try to ping the remote host to see if this worked. *)
443 shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
445 if state.greeting then (
446 printf "\n\nDid automatic network configuration work?\n";
447 printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
449 let line = read_line () in
450 String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
453 (* Non-interactive: return the status of /etc/init.d/network start. *)
456 (* Map local device names to remote devices names. At the moment we
457 * just change sd* to hd* (as device names appear under fullvirt). In
458 * future, lots of complex possibilities.
460 let remote_of_origin_dev =
461 let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
462 let devsd_subst = Pcre.subst "hd$1" in
464 Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
466 (* Rewrite /mnt/root/etc/fstab. *)
467 let rewrite_fstab state devices_to_send =
468 let filename = "/mnt/root/etc/fstab" in
469 if is_file filename = Some true then (
470 sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
472 let chan = open_in filename in
473 let lines = input_all_lines chan in
475 let lines = List.map (Pcre.split ~rex:whitespace) lines in
476 let lines = List.map (
478 | dev :: rest when String.starts_with dev "/dev/" ->
479 let dev = String.sub dev 5 (String.length dev - 5) in
480 let dev = remote_of_origin_dev dev in
481 let dev = "/dev/" ^ dev in
486 let chan = open_out filename in
489 | [dev; mountpoint; fstype; options; freq; passno] ->
490 fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
491 dev mountpoint fstype options freq passno
493 output_string chan (String.concat " " line)
498 (* Main entry point. *)
499 let rec main ttyname =
500 (* Running from an init script. We don't have much of a
501 * login environment, so set one up.
505 ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
506 "/usr/bin"; "/bin"]);
507 putenv "HOME" "/root";
508 putenv "LOGNAME" "root";
510 (* We can safely write in /tmp (it's a synthetic live CD directory). *)
513 (* Set up logging to /tmp/virt-p2v.log. *)
514 let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
518 (* Log the start up time. *)
519 eprintf "\n\n**************************************************\n\n";
520 let tm = localtime (time ()) in
521 eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
522 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
524 (* Connect stdin/stdout to the tty. *)
528 let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
532 printf "virt-p2v.ml starting up ...\n%!";
534 (* Search for all non-removable block devices. Do this early and bail
535 * if we can't find anything. This is a list of strings, like "hda".
537 let all_block_devices : block_device list =
538 let rex = Pcre.regexp "^[hs]d" in
539 let devices = Array.to_list (Sys.readdir "/sys/block") in
540 let devices = List.sort devices in
541 let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
542 eprintf "all_block_devices: block devices: %s\n%!"
543 (String.concat "; " devices);
544 (* Run blockdev --getsize64 on each, and reject any where this fails
545 * (probably removable devices).
547 let devices = List.filter_map (
549 let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
550 let lines = shget cmd in
552 | Some (blksize::_) -> Some (d, Int64.of_string blksize)
553 | Some [] | None -> None
555 eprintf "all_block_devices: non-removable block devices: %s\n%!"
557 (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
559 fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
562 (* Search for partitions and LVs (anything that could contain a
563 * filesystem directly). We refer to these generically as
566 let all_partitions : partition list =
569 let lvs = get_lvs () in
570 let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
571 let pvs = List.concat pvs in
572 let pvs = sort_uniq pvs in
573 eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
574 let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
575 eprintf "all_partitions: LVs: %s\n%!"
576 (String.concat "; " (List.map dev_of_partition lvs));
579 (* Partitions (eg. "sda1", "sda2"). *)
581 let parts = List.map fst all_block_devices in
582 let parts = List.map get_partitions parts in
583 let parts = List.concat parts in
584 eprintf "all_partitions: all partitions: %s\n%!"
585 (String.concat "; " (List.map dev_of_partition parts));
587 (* Remove any partitions which are PVs. *)
588 let parts = List.filter (
590 | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
591 | LV _ -> assert false
594 eprintf "all_partitions: partitions after removing PVs: %s\n%!"
595 (String.concat "; " (List.map dev_of_partition parts));
597 (* Concatenate LVs & Parts *)
601 let ask_greeting state =
602 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);
606 let ask_transport state =
608 radiolist "Connection type" ~backbutton:false
611 "ssh", "SSH (secure shell)", state.transport = Some SSH;
612 "server", "P2V server on remote host", state.transport = Some Server
615 | Yes ("ssh"::_) -> Next { state with transport = Some SSH }
616 | Yes ("server"::_) -> Next { state with transport = Some Server }
617 | Yes _ | No | Help | Error -> Ask_again
621 let ask_hostname state =
623 inputbox "Remote host" "Remote host" 10 50
624 (Option.default "" state.remote_host)
626 | Yes [] -> Ask_again
627 | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
628 | No | Help | Error -> Ask_again
634 inputbox "Remote port" "Remote port" 10 50
635 (Option.default "" state.remote_port)
638 (match state.transport with
639 | Some SSH -> Next { state with remote_port = Some "22" }
640 | _ -> Next { state with remote_port = Some "16211" }
642 | Yes (port::_) -> Next { state with remote_port = Some port }
643 | No | Help | Error -> Ask_again
647 let ask_directory state =
649 inputbox "Remote directory" "Remote directory" 10 50
650 (Option.default "" state.remote_directory)
653 Next { state with remote_directory = Some "/var/lib/xen/images" }
654 | Yes (dir::_) -> Next { state with remote_directory = Some dir }
655 | No | Help | Error -> Ask_again
659 let ask_network state =
661 radiolist "Network configuration" "Network configuration" 10 50 2 [
662 "auto", "Automatic configuration", state.network = Some Auto;
663 "sh", "Configure from the shell", state.network = Some Shell;
666 | Yes ("auto"::_) -> Next { state with network = Some Auto }
667 | Yes ("sh"::_) -> Next { state with network = Some Shell }
668 | Yes _ | No | Help | Error -> Ask_again
672 let ask_devices state =
673 let selected_devices = Option.default [] state.devices_to_send in
674 let devices = List.map (
675 fun (dev, blksize) ->
677 sprintf "/dev/%s (%.3f GB)" dev
678 ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
679 List.mem dev selected_devices)
680 ) all_block_devices in
682 checklist "Devices" "Pick devices to send" 15 50 8 devices
684 | Yes [] | No | Help | Error -> Ask_again
685 | Yes devices -> Next { state with devices_to_send = Some devices }
690 let parts = List.mapi (
692 (string_of_int i, dev_of_partition part,
693 Some part = state.root_filesystem)
696 radiolist "Root device"
697 "Pick partition containing the root (/) filesystem" 15 50 6
701 let part = List.nth all_partitions (int_of_string i) in
702 Next { state with root_filesystem = Some part }
703 | Yes [] | No | Help | Error -> Ask_again
707 let ask_hypervisor state =
709 radiolist "Hypervisor"
710 "Choose hypervisor / virtualization system"
712 "xen", "Xen", state.hypervisor = Some Xen;
713 "qemu", "QEMU", state.hypervisor = Some QEMU;
714 "kvm", "KVM", state.hypervisor = Some KVM;
715 "other", "Other", state.hypervisor = None
718 | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
719 | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
720 | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
721 | Yes _ -> Next { state with hypervisor = None }
722 | No | Help | Error -> Ask_again
726 let ask_architecture state =
728 radiolist "Architecture" "Machine architecture" 16 50 8 [
729 "i386", "i386 and up (32 bit)", state.architecture = Some "i386";
730 "x86_64", "x86-64 (64 bit)", state.architecture = Some "x86_64";
731 "ia64", "Itanium IA64", state.architecture = Some "ia64";
732 "ppc", "PowerPC (32 bit)", state.architecture = Some "ppc";
733 "ppc64", "PowerPC (64 bit)", state.architecture = Some "ppc64";
734 "sparc", "SPARC (32 bit)", state.architecture = Some "sparc";
735 "sparc64", "SPARC (64 bit)", state.architecture = Some "sparc64";
736 (* "auto", "Other or auto-detect",
737 state.architecture = None || state.architecture = Some "";*)
740 | Yes (("auto"|"")::_ | []) -> Next { state with architecture = Some "" }
741 | Yes (arch :: _) -> Next { state with architecture = Some arch }
742 | No | Help | Error -> Ask_again
746 let ask_memory state =
748 inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
750 (Option.map_default string_of_int "" state.memory)
752 | Yes (""::_ | []) -> Next { state with memory = Some 0 }
754 let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
755 if mem < 0 || (mem > 0 && mem < 64) then Ask_again
756 else Next { state with memory = Some mem }
757 | No | Help | Error -> Ask_again
761 let ask_vcpus state =
763 inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
765 (Option.map_default string_of_int "" state.vcpus)
767 | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
770 try int_of_string vcpus with Failure "int_of_string" -> -1 in
771 if vcpus < 0 then Ask_again
772 else Next { state with vcpus = Some vcpus }
773 | No | Help | Error -> Ask_again
777 let ask_mac_address state =
779 inputbox "MAC address"
780 "Network MAC address. Leave blank to use a random address." 10 50
781 (Option.default "" state.mac_address)
783 | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
784 | Yes (mac :: _) -> Next { state with mac_address = Some mac }
785 | No | Help | Error -> Ask_again
789 let ask_verify state =
791 yesno "Verify and proceed"
792 (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
805 (match state.transport with
806 | Some Server -> "Server" | Some SSH -> "SSH"
808 (Option.default "" state.remote_host)
809 (Option.default "" state.remote_port)
810 (Option.default "" state.remote_directory)
811 (match state.network with
812 | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
814 (String.concat "," (Option.default [] state.devices_to_send))
815 (Option.map_default dev_of_partition "" state.root_filesystem)
816 (match state.hypervisor with
817 | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
818 | None -> "Other / not set")
819 (match state.architecture with
820 | Some "" -> "Guess" | Some arch -> arch | None -> "")
821 (match state.memory with
822 | Some 0 -> "Same as physical"
823 | Some mem -> string_of_int mem ^ " MB" | None -> "")
824 (match state.vcpus with
825 | Some 0 -> "Same as physical"
826 | Some vcpus -> string_of_int vcpus | None -> "")
827 (match state.mac_address with
828 | Some "" -> "Random" | Some mac -> mac | None -> "")
832 | Yes _ -> Next state
834 | No | Help | Error -> Ask_again
837 (* This is the list of dialogs, in order. The user can go forwards or
838 * backwards through them. The second parameter in each pair is
839 * false if we need to skip this dialog (info already supplied in
843 ask_greeting, (* Initial greeting. *)
845 ask_transport, (* Transport (ssh, tcp) *)
846 defaults.transport = None;
847 ask_hostname, (* Hostname. *)
848 defaults.remote_host = None;
849 ask_port, (* Port number. *)
850 defaults.remote_port = None;
851 ask_directory, (* Remote directory. *)
852 defaults.remote_directory = None;
853 ask_network, (* Network configuration. *)
854 defaults.network = None;
855 ask_devices, (* Block devices to send. *)
856 defaults.devices_to_send = None;
857 ask_root, (* Root filesystem. *)
858 defaults.root_filesystem = None;
859 ask_hypervisor, (* Hypervisor. *)
860 defaults.hypervisor = None;
861 ask_architecture, (* Architecture. *)
862 defaults.architecture = None;
863 ask_memory, (* Memory. *)
864 defaults.memory = None;
865 ask_vcpus, (* VCPUs. *)
866 defaults.vcpus = None;
867 ask_mac_address, (* MAC address. *)
868 defaults.mac_address = None;
869 ask_verify, (* Verify settings. *)
873 (* Loop through the dialogs until we reach the end. *)
874 let rec loop posn state =
875 eprintf "dialog loop: posn = %d\n%!" posn;
876 if posn >= Array.length dlgs then state (* Finished all dialogs. *)
878 let dlg, no_skip = dlgs.(posn) in
879 let skip = not no_skip in
881 (* Skip this dialog and move straight to the next one. *)
886 | Next new_state -> loop (posn+1) new_state (* Forwards. *)
887 | Prev -> loop (posn-1) state (* Backwards / back button. *)
888 | Ask_again -> loop posn state (* Repeat the question. *)
892 let state = loop 0 defaults in
894 eprintf "finished dialog loop\n%!";
896 (* Check that the environment is a sane-looking live CD. If not, bail. *)
897 if is_dir "/mnt/root" <> Some true then
898 fail_dialog "You should only run this script from the live CD or a USB key.";
900 (* Switch LVM config. *)
902 putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
903 sh "rm -f /etc/lvm/cache/.cache";
904 sh "rm -f /etc/lvm.new/cache/.cache";
906 (* Snapshot the block devices to send. *)
907 let devices_to_send = Option.get state.devices_to_send in
908 let devices_to_send =
911 let snapshot_dev = snapshot_name origin_dev in
912 snapshot origin_dev snapshot_dev;
913 (origin_dev, snapshot_dev)
916 (* Run kpartx on the snapshots. *)
918 fun (origin, snapshot) ->
919 shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
922 (* Rescan for LVs. *)
926 (* Mount the root filesystem under /mnt/root. *)
927 let root_filesystem = Option.get state.root_filesystem in
928 (match root_filesystem with
929 | Part (dev, partnum) ->
930 let dev = dev ^ partnum in
931 let snapshot_dev = snapshot_name dev in
932 sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
935 (* The LV will be backed by a snapshot device, so just mount
938 sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
941 (* See if we can do network configuration. *)
942 let network = Option.get state.network in
945 printf "Network configuration.\n\n";
946 printf "Please configure the network from this shell.\n\n";
947 printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
952 "Trying network auto-configuration from root filesystem ...\n\n%!";
953 if not (auto_network state) then (
954 printf "\nAuto-configuration failed. Starting a shell.\n\n";
955 printf "Please configure the network from this shell.\n\n";
956 printf "When you have finished, exit the shell with ^D or exit.\n\n";
961 (* Work out what devices will be called at the remote end. *)
962 let devices_to_send = List.map (
963 fun (origin_dev, snapshot_dev) ->
964 let remote_dev = remote_of_origin_dev origin_dev in
965 (origin_dev, snapshot_dev, remote_dev)
968 (* Modify files on the root filesystem. *)
969 rewrite_fstab state devices_to_send;
970 (* XXX Other files to rewrite? *)
972 (* XXX Autodetect architecture of root filesystem by looking for /bin/ls. *)
973 let system_architecture = "x86_64" in
975 (* XXX Autodetect system memory. *)
976 let system_memory = 256 in
978 (* XXX Autodetect system # pCPUs. *)
979 let system_nr_cpus = 1 in
981 (* Unmount the root filesystem and sync disks. *)
982 sh "umount /mnt/root";
983 sh "sync"; (* Ugh, should be in stdlib. *)
985 (* Disable screen blanking on console. *)
986 sh "setterm -blank 0";
988 let remote_host = Option.get state.remote_host in
989 let remote_port = Option.get state.remote_port in
990 let remote_directory = Option.get state.remote_directory in
991 let transport = Option.get state.transport in
993 (* Connect and disconnect from the remote system. *)
994 let do_connect, do_disconnect =
997 let do_connect remote_name size =
999 getaddrinfo remote_host remote_port [AI_SOCKTYPE SOCK_STREAM] in
1000 let rec loop = function
1003 (sprintf "Unable to connect to %s:%s" remote_host remote_port)
1007 socket addr.ai_family addr.ai_socktype addr.ai_protocol in
1008 connect sock addr.ai_addr;
1009 let header = sprintf "p2v2 %s %Ld\n%!" remote_name size in
1010 let len = String.length header in
1011 assert (len = write sock header 0 len);
1013 with Unix_error (err, syscall, extra) ->
1014 (* Log the error message, but continue around the loop. *)
1015 eprintf "%s:%s: %s\n%!" syscall extra (error_message err);
1020 let do_disconnect sock = close sock in
1021 do_connect, do_disconnect
1023 (* Cheat by keeping a private variable around containing the original
1024 * channel, so we can close it easily. (XXX)
1026 let chan = ref None in
1027 let do_connect remote_name _ =
1028 let cmd = sprintf "ssh -C -p %s %s \"cat > %s/%s\""
1029 (quote remote_port) (quote remote_host)
1030 (quote remote_directory) (quote remote_name) in
1031 let c = open_process_out cmd in
1033 descr_of_out_channel c
1035 let do_disconnect _ =
1036 (match close_process_out (Option.get !chan) with
1037 | WEXITED 0 -> () (* OK *)
1038 | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
1039 | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
1040 | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
1044 do_connect, do_disconnect in
1046 (* XXX This is using the hostname derived from network configuration
1047 * above. We might want to ask the user to choose.
1049 let hostname = safe_name (gethostname ()) in
1051 let date = sprintf "%04d%02d%02d%02d%02d"
1052 (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1053 "p2v-" ^ hostname ^ "-" ^ date in
1055 (* Work out what the image filenames will be at the remote end. *)
1056 let devices_to_send = List.map (
1057 fun (origin_dev, snapshot_dev, remote_dev) ->
1058 let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1059 (origin_dev, snapshot_dev, remote_dev, remote_name)
1060 ) devices_to_send in
1062 (* Write a configuration file. Not sure if this is any better than
1063 * just 'sprintf-ing' bits of XML text together, but at least we will
1064 * always get well-formed XML.
1066 * XXX For some of the stuff here we really should do a
1067 * virConnectGetCapabilities call to the remote host first.
1069 * XXX There is a case for using virt-install to generate this XML.
1070 * When we start to incorporate libvirt access & storage API this
1071 * needs to be rethought.
1073 let conf_filename = basename ^ ".conf" in
1076 match state.architecture with
1077 | Some "" | None -> system_architecture
1078 | Some arch -> arch in
1080 match state.memory with
1081 | Some memory -> memory
1082 | None -> system_memory in
1084 match state.vcpus with
1085 | Some 0 | None -> system_nr_cpus
1088 match state.mac_address with
1091 List.map (sprintf "%02x") (
1092 List.map (fun _ -> Random.int 256) [0;0;0]
1094 String.concat ":" ("00"::"16"::"3e"::random)
1095 | Some mac -> mac in
1098 (* Shortcut to make "<name>value</name>". *)
1099 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1100 (* ... and the _other_ sort of leaf (god I hate XML). *)
1101 let tleaf name attribs = Xml.Element (name, attribs, []) in
1103 (* Standard stuff for every domain. *)
1104 let name = leaf "name" hostname in
1105 let memory = leaf "memory" (string_of_int (memory * 1024)) in
1106 let vcpu = leaf "vcpu" (string_of_int vcpus) in
1108 (* Top-level stuff which differs for each HV type (isn't this supposed
1109 * to be portable ...)
1112 match state.hypervisor with
1114 [Xml.Element ("os", [],
1116 leaf "loader" "/usr/lib/xen/boot/hvmloader";
1117 tleaf "boot" ["dev", "hd"]]);
1118 Xml.Element ("features", [],
1122 tleaf "clock" ["sync", "localtime"]]
1124 [Xml.Element ("os", [], [leaf "type" "hvm"]);
1125 tleaf "clock" ["sync", "localtime"]]
1127 [Xml.Element ("os", [],
1128 [Xml.Element ("type", ["arch",architecture;
1130 [Xml.PCData "hvm"]);
1131 tleaf "boot" ["dev", "hd"]])]
1135 (* <devices> section. *)
1138 match state.hypervisor with
1140 [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1142 [leaf "emulator" "/usr/bin/qemu"]
1144 [leaf "emulator" "/usr/bin/qemu-kvm"]
1148 Xml.Element ("interface", ["type", "user"],
1149 [tleaf "mac" ["address", mac_address]]) in
1150 (* XXX should have an option for Xen bridging:
1152 "interface", ["type","bridge"],
1153 [tleaf "source" ["bridge","xenbr0"];
1154 tleaf "mac" ["address",mac_address];
1155 tleaf "script" ["path","vif-bridge"]])*)
1156 let graphics = tleaf "graphics" ["type", "vnc"] in
1158 let disks = List.map (
1159 fun (_, _, remote_dev, remote_name) ->
1161 "disk", ["type", "file";
1163 [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1164 tleaf "target" ["dev", remote_dev]]
1166 ) devices_to_send in
1170 emulator @ interface :: graphics :: disks
1173 (* Put it all together in <domain type='foo'>. *)
1176 (match state.hypervisor with
1177 | Some Xen -> ["type", "xen"]
1178 | Some QEMU -> ["type", "qemu"]
1179 | Some KVM -> ["type", "kvm"]
1181 name :: memory :: vcpu :: extras @ [devices]
1184 let xml = Xml.to_string_fmt xml in
1185 let xml_len = String.length xml in
1186 eprintf "length of configuration file is %d bytes\n%!" xml_len;
1188 let sock = do_connect conf_filename (Int64.of_int xml_len) in
1189 (* In OCaml this actually loops calling write(2) *)
1190 ignore (write sock xml 0 xml_len);
1193 (* Send the device snapshots to the remote host. *)
1194 (* XXX This code should be made more robust against both network
1195 * errors and local I/O errors. Also should allow the user several
1196 * attempts to connect, or let them go back to the dialog stage.
1199 fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1200 eprintf "sending %s as %s\n%!" origin_dev remote_name;
1203 try List.assoc origin_dev all_block_devices
1204 with Not_found -> assert false (* internal error *) in
1206 printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1207 ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1209 (* Open the snapshot device. *)
1210 let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1213 let sock = do_connect remote_name size in
1215 (* Copy the data. *)
1216 let bufsize = 1024 * 1024 in
1217 let buffer = String.create bufsize in
1218 let start = gettimeofday () in
1220 let rec copy bytes_sent last_printed_at =
1221 let n = read fd buffer 0 bufsize in
1223 ignore (write sock buffer 0 n);
1225 let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1226 let last_printed_at =
1227 let now = gettimeofday () in
1228 (* Print progress once per second. *)
1229 if now -. last_printed_at > 1. then (
1230 let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1231 let secs_elapsed = now -. start in
1232 printf "%.0f%%" (100. *. elapsed);
1233 (* After 60 seconds has elapsed, start printing estimates. *)
1234 if secs_elapsed >= 60. then (
1235 let remaining = 1. -. elapsed in
1236 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1237 if secs_remaining > 120. then
1238 printf " (about %.0f minutes remaining) "
1239 (secs_remaining /. 60.)
1241 printf " (about %.0f seconds remaining) "
1247 else last_printed_at in
1249 copy bytes_sent last_printed_at
1258 (* Clean up and reboot. *)
1260 msgbox "virt-p2v completed"
1261 (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."
1262 remote_directory conf_filename)
1271 eprintf "usage: virt-p2v [ttyname]\n%!";
1274 (* Make sure that exceptions from 'main' get printed out on stdout
1275 * as well as stderr, since stderr is probably redirected to the
1276 * logfile, and so not visible to the user.
1278 let handle_exn f arg =
1280 with exn -> print_endline (Printexc.to_string exn); raise exn
1282 (* If the ISO image has an attachment then it could be a new version
1283 * of virt-p2v.ml (this script). Get the attachment and run it
1284 * instead. Useful mainly for testing, in conjunction with the
1285 * 'make update' target in the virt-p2v Makefile.
1287 let magic = "ISOATTACHMENT002"
1288 let magiclen = String.length magic (* = 16 bytes *)
1289 let trailerlen = magiclen + 8 + 8 (* magic + file start + true size *)
1291 let int64_of_string str =
1293 let add offs shift =
1296 (Int64.shift_left (Int64.of_int (Char.code str.[offs])) shift) !i
1298 add 0 56; add 1 48; add 2 40; add 3 32;
1299 add 4 24; add 5 16; add 6 8; add 7 0;
1302 let update ttyname =
1303 let cdrom = "/dev/cdrom" in
1304 let output = "/tmp/virt-p2v.ml" in
1307 let fd = openfile cdrom [O_RDONLY] 0 in
1308 ignore (LargeFile.lseek fd (Int64.of_int ~-trailerlen) SEEK_END);
1309 let buf = String.create magiclen in
1310 if read fd buf 0 magiclen <> magiclen || buf <> magic then (
1315 (* Read the size. *)
1316 let buf = String.create 8 in
1317 if read fd buf 0 8 <> 8 then
1318 failwith "cannot read attachment offset";
1319 let offset = int64_of_string buf in
1320 let buf = String.create 8 in
1321 if read fd buf 0 8 <> 8 then
1322 failwith "cannot read attachment size";
1323 let size = Int64.to_int (int64_of_string buf) in
1325 (* Seek to beginning of the attachment. *)
1326 ignore (LargeFile.lseek fd offset SEEK_SET);
1328 (* Copy out the attachment. *)
1329 let fd2 = openfile output [O_WRONLY; O_CREAT; O_TRUNC] 0o755 in
1330 let bufsize = 4 * 1024 in
1331 let buffer = String.create bufsize in
1332 let rec copy remaining =
1333 if remaining > 0 then (
1334 let n = min remaining bufsize in
1335 let n = read fd buffer 0 n in
1336 if n = 0 then failwith "corrupted or partial attachment";
1337 ignore (write fd2 buffer 0 n);
1338 copy (remaining - n)
1346 (* Run updated virt-p2v script. *)
1347 execv output [| output; ttyname |]
1349 Unix_error _ | Exit ->
1350 (* Some error, or no attachment, so keep running this script. *)
1351 handle_exn main (Some ttyname)
1353 (* Test harness for the Makefile. The Makefile invokes this script as
1354 * 'virt-p2v.ml --test' just to check it compiles. When it is running
1355 * from the actual live CD, there is a single parameter which is the
1356 * tty name (so usually 'virt-p2v.ml tty1').
1359 match Array.to_list Sys.argv with
1360 | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
1361 | [ _; "--update"; ttyname ] -> (* Test for update and run. *)
1363 | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1364 | [ _; ttyname ] -> (* Run main with ttyname. *)
1365 handle_exn main (Some ttyname)
1366 | [ _ ] -> (* Interactive - no ttyname. *)
1367 handle_exn main None
1370 (* This file must end with a newline *)