+(* General helper functions. *)
+
+let sort_uniq ?(cmp = compare) xs = (* sort and uniq a list *)
+ let xs = List.sort ~cmp xs in
+ let rec loop = function
+ | [] -> [] | [x] -> [x]
+ | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
+ | x :: xs -> x :: loop xs
+ in
+ loop xs
+
+let input_all_lines chan =
+ let lines = ref [] in
+ try
+ while true do lines := input_line chan :: !lines done; []
+ with
+ End_of_file -> List.rev !lines
+
+let dev_of_partition = function
+ | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
+ | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
+
+type dialog_status = Yes of string list | No | Help | Back | Error
+
+type ask_result = Next of state | Prev | Ask_again
+
+(* Dialog functions.
+ *
+ * Each function takes some common parameters (eg. ~title) and some
+ * dialog-specific parameters.
+ *
+ * Returns the exit status (Yes lines | No | Help | Back | Error).
+ *)
+let msgbox, yesno, inputbox, radiolist, checklist =
+ (* Internal function to actually run the "dialog" shell command. *)
+ let run_dialog cparams params =
+ let params = cparams @ params in
+ eprintf "dialog %s\n%!"
+ (String.concat " " (List.map (sprintf "%S") params));
+
+ (* 'dialog' writes its output/result to stderr, so we need to take
+ * special steps to capture that - in other words, manual pipe/fork.
+ *)
+ let rfd, wfd = pipe () in
+ match fork () with
+ | 0 -> (* child, runs dialog *)
+ close rfd;
+ dup2 wfd stderr; (* capture stderr to pipe *)
+ execvp "dialog" (Array.of_list ("dialog" :: params))
+ | pid -> (* parent *)
+ close wfd;
+ let chan = in_channel_of_descr rfd in
+ let result = input_all_lines chan in
+ close rfd;
+ eprintf "dialog result: %S\n%!" (String.concat "\n" result);
+ match snd (wait ()) with
+ | WEXITED 0 -> Yes result (* something selected / entered *)
+ | WEXITED 1 -> No (* cancel / no button *)
+ | WEXITED 2 -> Help (* help pressed *)
+ | WEXITED 3 -> Back (* back button *)
+ | WEXITED _ -> Error (* error or Esc *)
+ | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
+ | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
+ in
+
+ (* Handle the common parameters. Note Continuation Passing Style. *)
+ let with_common cont ?(cancel=false) ?(backbutton=true) title =
+ let params = ["--title"; title] in
+ let params = if not cancel then "--nocancel" :: params else params in
+ let params =
+ if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
+ else params in
+ cont params
+ in
+
+ (* Message box and yes/no box. *)
+ let rec msgbox =
+ with_common (
+ fun cparams text height width ->
+ run_dialog cparams
+ [ "--msgbox"; text; string_of_int height; string_of_int width ]
+ )
+ and yesno =
+ with_common (
+ fun cparams text height width ->
+ run_dialog cparams
+ [ "--yesno"; text; string_of_int height; string_of_int width ]
+ )
+
+ (* Simple input box. *)
+ and inputbox =
+ with_common (
+ fun cparams text height width default ->
+ run_dialog cparams
+ [ "--inputbox"; text; string_of_int height; string_of_int width;
+ default ]
+ )
+
+ (* Radio list and check list. *)
+ and radiolist =
+ with_common (
+ fun cparams text height width listheight items ->
+ let items = List.map (
+ function
+ | tag, item, true -> [ tag; item; "on" ]
+ | tag, item, false -> [ tag; item; "off" ]
+ ) items in
+ let items = List.concat items in
+ let items = "--single-quoted" ::
+ "--radiolist" :: text ::
+ string_of_int height :: string_of_int width ::
+ string_of_int listheight :: items in
+ run_dialog cparams items
+ )
+ and checklist =
+ with_common (
+ fun cparams text height width listheight items ->
+ let items = List.map (
+ function
+ | tag, item, true -> [ tag; item; "on" ]
+ | tag, item, false -> [ tag; item; "off" ]
+ ) items in
+ let items = List.concat items in
+ let items = "--separate-output" ::
+ "--checklist" :: text ::
+ string_of_int height :: string_of_int width ::
+ string_of_int listheight :: items in
+ run_dialog cparams items
+ )
+ in
+ msgbox, yesno, inputbox, radiolist, checklist
+
+(* Print failure dialog and exit. *)
+let fail_dialog text =
+ 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
+ ignore (msgbox "Error" text 17 50);
+ exit 1
+
+(* Shell-safe quoting function. In fact there's one in stdlib so use it. *)
+let quote = Filename.quote
+
+(* Run a shell command and check it returns 0. *)
+let sh cmd =
+ eprintf "sh: %s\n%!" cmd;
+ if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
+
+let shfailok cmd =
+ eprintf "shfailok: %s\n%!" cmd;
+ ignore (Sys.command cmd)
+
+let shwithstatus cmd =
+ eprintf "shwithstatus: %s\n%!" cmd;
+ Sys.command cmd
+
+(* Same as `cmd` in shell. Any error message will be in the logfile. *)
+let shget cmd =
+ eprintf "shget: %s\n%!" cmd;
+ let chan = open_process_in cmd in
+ let lines = input_all_lines chan in
+ match close_process_in chan with
+ | WEXITED 0 -> Some lines (* command succeeded *)
+ | WEXITED _ -> None (* command failed *)
+ | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
+ | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
+
+(* Start an interactive shell. *)
+let shell () =
+ shfailok "PS1='\\u@\\h:\\w\\$ ' bash"
+
+(* Some true if is dir/file, Some false if not, None if not found. *)
+let is_dir path =
+ try Some ((stat path).st_kind = S_DIR)
+ with Unix_error (ENOENT, "stat", _) -> None
+let is_file path =
+ try Some ((stat path).st_kind = S_REG)
+ with Unix_error (ENOENT, "stat", _) -> None
+
+(* Useful regular expression. *)
+let whitespace = Pcre.regexp "[ \t]+"
+
+(* Generate a predictable safe name containing only letters, numbers
+ * and underscores. If passed a string with no letters or numbers,
+ * generates "_1", "_2", etc.
+ *)
+let safe_name =
+ let next_anon =
+ let i = ref 0 in
+ fun () -> incr i; "_" ^ string_of_int !i
+ in
+ fun name ->
+ let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
+ let name = String.copy name in
+ let have_safe = ref false in
+ for i = 0 to String.length name - 1 do
+ if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
+ done;
+ if !have_safe then name else next_anon ()
+
+type block_device = string * int64 (* "hda" & size in bytes *)
+
+(* Parse the output of 'lvs' to get list of LV names, sizes,
+ * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize).
+ *)
+let get_lvs =
+ let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
+
+ function () ->
+ match
+ shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
+ with
+ | None -> []
+ | Some lines ->
+ let lines = List.map (Pcre.split ~rex:whitespace) lines in
+ List.map (
+ function
+ | [vg; lv; pvs; lvsize]
+ | [_; vg; lv; pvs; lvsize] ->
+ let pvs = String.nsplit pvs "," in
+ let pvs = List.filter_map (
+ fun pv ->
+ try
+ let subs = Pcre.exec ~rex:devname pv in
+ Some (Pcre.get_substring subs 1)
+ with
+ Not_found ->
+ eprintf "lvs: unexpected device name: %s\n%!" pv;
+ None
+ ) pvs in
+ LV (vg, lv), pvs, lvsize
+ | line ->
+ failwith ("lvs: unexpected output: " ^ String.concat "," line)
+ ) lines
+
+(* Get the partitions on a block device.
+ * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
+ *)
+let get_partitions dev =
+ let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
+ let devdir = "/sys/block/" ^ dev in
+ let parts = Sys.readdir devdir in
+ let parts = Array.to_list parts in
+ let parts = List.filter (
+ fun name -> Some true = is_dir (devdir ^ "/" ^ name)
+ ) parts in
+ let parts = List.filter_map (
+ fun part ->
+ try
+ let subs = Pcre.exec ~rex part in
+ Some (Part (dev, Pcre.get_substring subs 1))
+ with
+ Not_found -> None
+ ) parts in
+ parts
+
+(* Generate snapshot device name from device name. *)
+let snapshot_name dev =
+ "snap" ^ (safe_name dev)
+
+(* Perform a device-mapper snapshot with ramdisk overlay. *)
+let snapshot =
+ let next_free_ram_disk =
+ let i = ref 0 in
+ fun () -> incr i; "/dev/ram" ^ string_of_int !i
+ in
+ fun origin_dev snapshot_dev ->
+ let ramdisk = next_free_ram_disk () in
+ let sectors =
+ let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
+ let lines = shget cmd in
+ match lines with
+ | Some (sectors::_) -> Int64.of_string sectors
+ | Some [] | None ->
+ fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
+
+ (* Create the snapshot origin device. Called, eg. snap_sda1_org *)
+ sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
+ snapshot_dev sectors origin_dev);
+ (* Create the snapshot. *)
+ sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
+ snapshot_dev sectors snapshot_dev ramdisk)
+
+(* Try to perform automatic network configuration, assuming a Fedora or RHEL-
+ * like root filesystem mounted on /mnt/root.
+ *)
+let auto_network state =
+ (* Fedora gives an error if this file doesn't exist. *)
+ sh "touch /etc/resolv.conf";
+
+ chdir "/etc/sysconfig";
+
+ sh "mv network network.saved";
+ sh "mv networking networking.saved";
+ sh "mv network-scripts network-scripts.saved";
+
+ (* Originally I symlinked these, but that causes dhclient to
+ * keep open /mnt/root (as its cwd is in network-scripts subdir).
+ * So now we will copy them recursively instead.
+ *)
+ sh "cp -r /mnt/root/etc/sysconfig/network .";
+ sh "cp -r /mnt/root/etc/sysconfig/networking .";
+ sh "cp -r /mnt/root/etc/sysconfig/network-scripts .";
+
+ let status = shwithstatus "/etc/init.d/network start" in
+
+ sh "rm -rf network networking network-scripts";
+ sh "mv network.saved network";
+ sh "mv networking.saved networking";
+ sh "mv network-scripts.saved network-scripts";
+
+ chdir "/tmp";
+
+ (* Try to ping the remote host to see if this worked. *)
+ shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
+
+ if state.greeting then (
+ printf "\n\nDid automatic network configuration work?\n";
+ printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
+ printf " (y/n) %!";
+ let line = read_line () in
+ String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
+ )
+ else
+ (* Non-interactive: return the status of /etc/init.d/network start. *)
+ status = 0
+
+(* Map local device names to remote devices names. At the moment we
+ * just change sd* to hd* (as device names appear under fullvirt). In
+ * future, lots of complex possibilities.
+ *)
+let remote_of_origin_dev =
+ let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
+ let devsd_subst = Pcre.subst "hd$1" in
+ fun dev ->
+ Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
+
+(* Rewrite /mnt/root/etc/fstab. *)
+let rewrite_fstab state devices_to_send =
+ let filename = "/mnt/root/etc/fstab" in
+ if is_file filename = Some true then (
+ sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
+
+ let chan = open_in filename in
+ let lines = input_all_lines chan in
+ close_in chan;
+ let lines = List.map (Pcre.split ~rex:whitespace) lines in
+ let lines = List.map (
+ function
+ | dev :: rest when String.starts_with dev "/dev/" ->
+ let dev = String.sub dev 5 (String.length dev - 5) in
+ let dev = remote_of_origin_dev dev in
+ let dev = "/dev/" ^ dev in
+ dev :: rest
+ | line -> line
+ ) lines in
+
+ let chan = open_out filename in
+ List.iter (
+ function
+ | [dev; mountpoint; fstype; options; freq; passno] ->
+ fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
+ dev mountpoint fstype options freq passno
+ | line ->
+ output_string chan (String.concat " " line)
+ ) lines;
+ close_out chan
+ )
+