#!/usr/bin/ocamlrun /usr/bin/ocaml
#load "unix.cma";;
+#directory "+extlib";;
+#load "extLib.cma";;
+#directory "+pcre";;
+#load "pcre.cma";;
+#directory "+xml-light";;
+#load "xml-light.cma";;
+
(* virt-p2v.ml is a script which performs a physical to
* virtual conversion of local disks.
*
open Unix
open Printf
+open ExtList
+open ExtString
type state = { greeting : bool;
remote_host : string option; remote_port : string option;
- remote_transport : transport option;
+ transport : transport option;
remote_directory : string option;
+ network : network option;
devices_to_send : string list option;
- root_filesystem : string option; network : network option }
-and transport = SSH | TCP
+ root_filesystem : partition option;
+ hypervisor : hypervisor option;
+ architecture : string option;
+ memory : int option; vcpus : int option;
+ mac_address : string option;
+ }
+and transport = Server | SSH
and network = Auto | Shell
-
-type dialog_status = Yes | No | Help | Extra | Error
-
-let default d = function None -> d | Some p -> p
+and partition = Part of string * string (* eg. "hda", "1" *)
+ | LV of string * string (* eg. "VolGroup00", "LogVol00" *)
+and hypervisor = Xen | QEMU | KVM
(*----------------------------------------------------------------------*)
(* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
*)
greeting = true;
- (* Transport: Set to 'Some SSH' or 'Some TCP' to assume SSH or TCP
- * respectively.
+ (* Transport: Set to 'Some Server' or 'Some SSH' to assume Server or SSH
+ * transports respectively.
*)
- remote_transport = None;
+ transport = None;
(* Remote host and port. Set to 'Some "host"' and 'Some "port"',
* else ask the user.
*)
devices_to_send = None;
- (* The root filesystem containing /etc/fstab. Set to 'Some "sda3"'
- * or 'Some "VolGroup00/LogVol00"' for example, else ask user.
+ (* The root filesystem containing /etc/fstab. Set to
+ * 'Some (Part ("sda", "3"))' or 'Some (LV ("VolGroup00", "LogVol00"))'
+ * for example, else ask user.
*)
root_filesystem = None;
*)
network = None;
+ (* Hypervisor: Set to 'Some Xen', 'Some QEMU' or 'Some KVM'. *)
+ hypervisor = None;
+
+ (* Architecture: Set to 'Some "x86_64"' (or another architecture).
+ * If set to 'Some ""' then we try to autodetect the right architecture.
+ *)
+ architecture = None;
+
+ (* Memory: Set to 'Some nn' with nn in megabytes. If set to 'Some 0'
+ * then we use same amount of RAM as installed in the physical machine.
+ *)
+ memory = None;
+
+ (* Virtual CPUs: Set to 'Some nn' where nn is the number of virtual CPUs.
+ * If set to 'Some 0' then we use the same as physical CPUs in the
+ * physical machine.
+ *)
+ vcpus = None;
+
+ (* MAC address: Set to 'Some "aa:bb:cc:dd:ee:ff"' where the string is
+ * the MAC address of the emulated network card. Set to 'Some ""' to
+ * choose a random MAC address.
+ *)
+ mac_address = None;
}
(* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
(*----------------------------------------------------------------------*)
+(* 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
+ )
+
(* Main entry point. *)
let rec main ttyname =
(* Running from an init script. We don't have much of a
(* Log the start up time. *)
eprintf "\n\n**************************************************\n\n";
let tm = localtime (time ()) in
- eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n%!"
+ eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
(tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
(* Connect stdin/stdout to the tty. *)
dup2 fd stdin;
dup2 fd stdout;
close fd);
+ printf "virt-p2v.ml starting up ...\n%!";
+
+ (* Search for all non-removable block devices. Do this early and bail
+ * if we can't find anything. This is a list of strings, like "hda".
+ *)
+ let all_block_devices : block_device list =
+ let rex = Pcre.regexp "^[hs]d" in
+ let devices = Array.to_list (Sys.readdir "/sys/block") in
+ let devices = List.sort devices in
+ let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
+ eprintf "all_block_devices: block devices: %s\n%!"
+ (String.concat "; " devices);
+ (* Run blockdev --getsize64 on each, and reject any where this fails
+ * (probably removable devices).
+ *)
+ let devices = List.filter_map (
+ fun d ->
+ let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
+ let lines = shget cmd in
+ match lines with
+ | Some (blksize::_) -> Some (d, Int64.of_string blksize)
+ | Some [] | None -> None
+ ) devices in
+ eprintf "all_block_devices: non-removable block devices: %s\n%!"
+ (String.concat "; "
+ (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
+ if devices = [] then
+ fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
+ devices in
+
+ (* Search for partitions and LVs (anything that could contain a
+ * filesystem directly). We refer to these generically as
+ * "partitions".
+ *)
+ let all_partitions : partition list =
+ (* LVs & PVs. *)
+ let lvs, pvs =
+ let lvs = get_lvs () in
+ let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
+ let pvs = List.concat pvs in
+ let pvs = sort_uniq pvs in
+ eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
+ let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
+ eprintf "all_partitions: LVs: %s\n%!"
+ (String.concat "; " (List.map dev_of_partition lvs));
+ lvs, pvs in
+
+ (* Partitions (eg. "sda1", "sda2"). *)
+ let parts =
+ let parts = List.map fst all_block_devices in
+ let parts = List.map get_partitions parts in
+ let parts = List.concat parts in
+ eprintf "all_partitions: all partitions: %s\n%!"
+ (String.concat "; " (List.map dev_of_partition parts));
+
+ (* Remove any partitions which are PVs. *)
+ let parts = List.filter (
+ function
+ | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
+ | LV _ -> assert false
+ ) parts in
+ parts in
+ eprintf "all_partitions: partitions after removing PVs: %s\n%!"
+ (String.concat "; " (List.map dev_of_partition parts));
+
+ (* Concatenate LVs & Parts *)
+ lvs @ parts in
(* Dialogs. *)
- let rec ask_greeting state =
- ignore (
- dialog [
- title "virt-p2v" ();
- msgbox "\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." 17 50
- ]
- );
- Some state
-
- and ask_transport state =
- ignore ( (* XXX *)
- dialog [
- title "Connection type" ~cancel:false ();
- radiolist "Connection type" 10 50 2 [
- "ssh", "SSH (secure shell - recommended)",
- state.remote_transport = Some SSH;
- "tcp", "TCP socket",
- state.remote_transport = Some TCP
+ let ask_greeting state =
+ 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);
+ Next state
+ in
+
+ let ask_transport state =
+ match
+ radiolist "Connection type" ~backbutton:false
+ "Connection type."
+ 11 50 2 [
+ "ssh", "SSH (secure shell)", state.transport = Some SSH;
+ "server", "P2V server on remote host", state.transport = Some Server
]
+ with
+ | Yes ("ssh"::_) -> Next { state with transport = Some SSH }
+ | Yes ("server"::_) -> Next { state with transport = Some Server }
+ | Yes _ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
+ let ask_hostname state =
+ match
+ inputbox "Remote host" "Remote host" 10 50
+ (Option.default "" state.remote_host)
+ with
+ | Yes [] -> Ask_again
+ | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
+ let ask_port state =
+ match
+ inputbox "Remote port" "Remote port" 10 50
+ (Option.default "" state.remote_port)
+ with
+ | Yes [] ->
+ (match state.transport with
+ | Some SSH -> Next { state with remote_port = Some "22" }
+ | _ -> Next { state with remote_port = Some "16211" }
+ )
+ | Yes (port::_) -> Next { state with remote_port = Some port }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
+ let ask_directory state =
+ match
+ inputbox "Remote directory" "Remote directory" 10 50
+ (Option.default "" state.remote_directory)
+ with
+ | Yes [] ->
+ Next { state with remote_directory = Some "/var/lib/xen/images" }
+ | Yes (dir::_) -> Next { state with remote_directory = Some dir }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
+ let ask_network state =
+ match
+ radiolist "Network configuration" "Network configuration" 10 50 2 [
+ "auto", "Automatic configuration", state.network = Some Auto;
+ "sh", "Configure from the shell", state.network = Some Shell;
]
- );
- Some state
+ with
+ | Yes ("auto"::_) -> Next { state with network = Some Auto }
+ | Yes ("sh"::_) -> Next { state with network = Some Shell }
+ | Yes _ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
- and ask_hostname state =
- ignore ( (* XXX *)
- dialog [
- title "Remote host" ~cancel:false ~backbutton:true ();
- inputbox "Remote host" 10 50 (default "" state.remote_host)
- ]
- );
- Some state
+ let ask_devices state =
+ let selected_devices = Option.default [] state.devices_to_send in
+ let devices = List.map (
+ fun (dev, blksize) ->
+ (dev,
+ sprintf "/dev/%s (%.3f GB)" dev
+ ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
+ List.mem dev selected_devices)
+ ) all_block_devices in
+ match
+ checklist "Devices" "Pick devices to send" 15 50 8 devices
+ with
+ | Yes [] | No | Help | Error -> Ask_again
+ | Yes devices -> Next { state with devices_to_send = Some devices }
+ | Back -> Prev
+ in
+
+ let ask_root state =
+ let parts = List.mapi (
+ fun i part ->
+ (string_of_int i, dev_of_partition part,
+ Some part = state.root_filesystem)
+ ) all_partitions in
+ match
+ radiolist "Root device"
+ "Pick partition containing the root (/) filesystem" 15 50 6
+ parts
+ with
+ | Yes (i::_) ->
+ let part = List.nth all_partitions (int_of_string i) in
+ Next { state with root_filesystem = Some part }
+ | Yes [] | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
- and ask_port state =
- ignore ( (* XXX *)
- dialog [
- title "Remote port" ~cancel:false ~backbutton:true ();
- inputbox "Remote port" 10 50 (default "" state.remote_port)
+ let ask_hypervisor state =
+ match
+ radiolist "Hypervisor"
+ "Choose hypervisor / virtualization system"
+ 11 50 4 [
+ "xen", "Xen", state.hypervisor = Some Xen;
+ "qemu", "QEMU", state.hypervisor = Some QEMU;
+ "kvm", "KVM", state.hypervisor = Some KVM;
+ "other", "Other", state.hypervisor = None
]
- );
- Some state
+ with
+ | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
+ | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
+ | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
+ | Yes _ -> Next { state with hypervisor = None }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
+ let ask_architecture state =
+ match
+ radiolist "Architecture" "Machine architecture" 16 50 8 [
+ "i386", "i386 and up (32 bit)", state.architecture = Some "i386";
+ "x86_64", "x86-64 (64 bit)", state.architecture = Some "x86_64";
+ "ia64", "Itanium IA64", state.architecture = Some "ia64";
+ "ppc", "PowerPC (32 bit)", state.architecture = Some "ppc";
+ "ppc64", "PowerPC (64 bit)", state.architecture = Some "ppc64";
+ "sparc", "SPARC (32 bit)", state.architecture = Some "sparc";
+ "sparc64", "SPARC (64 bit)", state.architecture = Some "sparc64";
+(* "auto", "Other or auto-detect",
+ state.architecture = None || state.architecture = Some "";*)
+ ]
+ with
+ | Yes (("auto"|"")::_ | []) -> Next { state with architecture = Some "" }
+ | Yes (arch :: _) -> Next { state with architecture = Some arch }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
+ let ask_memory state =
+ match
+ inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
+ 10 50
+ (Option.map_default string_of_int "" state.memory)
+ with
+ | Yes (""::_ | []) -> Next { state with memory = Some 0 }
+ | Yes (mem::_) ->
+ let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
+ if mem < 0 || (mem > 0 && mem < 64) then Ask_again
+ else Next { state with memory = Some mem }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
+ let ask_vcpus state =
+ match
+ inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
+ 10 50
+ (Option.map_default string_of_int "" state.vcpus)
+ with
+ | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
+ | Yes (vcpus::_) ->
+ let vcpus =
+ try int_of_string vcpus with Failure "int_of_string" -> -1 in
+ if vcpus < 0 then Ask_again
+ else Next { state with vcpus = Some vcpus }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
+ let ask_mac_address state =
+ match
+ inputbox "MAC address"
+ "Network MAC address. Leave blank to use a random address." 10 50
+ (Option.default "" state.mac_address)
+ with
+ | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
+ | Yes (mac :: _) -> Next { state with mac_address = Some mac }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+ let ask_verify state =
+ match
+ yesno "Verify and proceed"
+ (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
+
+Connection: %s
+Host:port: %s : %s
+Directory: %s
+Network: %s
+Send devices: %s
+Root (/) dev: %s
+Hypervisor: %s
+Architecture: %s
+Memory: %s
+VCPUs: %s
+MAC address: %s"
+ (match state.transport with
+ | Some Server -> "Server" | Some SSH -> "SSH"
+ | None -> "")
+ (Option.default "" state.remote_host)
+ (Option.default "" state.remote_port)
+ (Option.default "" state.remote_directory)
+ (match state.network with
+ | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
+ | None -> "")
+ (String.concat "," (Option.default [] state.devices_to_send))
+ (Option.map_default dev_of_partition "" state.root_filesystem)
+ (match state.hypervisor with
+ | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
+ | None -> "Other / not set")
+ (match state.architecture with
+ | Some "" -> "Guess" | Some arch -> arch | None -> "")
+ (match state.memory with
+ | Some 0 -> "Same as physical"
+ | Some mem -> string_of_int mem ^ " MB" | None -> "")
+ (match state.vcpus with
+ | Some 0 -> "Same as physical"
+ | Some vcpus -> string_of_int vcpus | None -> "")
+ (match state.mac_address with
+ | Some "" -> "Random" | Some mac -> mac | None -> "")
+ )
+ 21 50
+ with
+ | Yes _ -> Next state
+ | Back -> Prev
+ | No | Help | Error -> Ask_again
in
(* This is the list of dialogs, in order. The user can go forwards or
ask_greeting, (* Initial greeting. *)
defaults.greeting;
ask_transport, (* Transport (ssh, tcp) *)
- defaults.remote_transport = None;
+ defaults.transport = None;
ask_hostname, (* Hostname. *)
defaults.remote_host = None;
ask_port, (* Port number. *)
defaults.remote_port = None;
-(* ask_directory, (* Remote directory. *)
+ ask_directory, (* Remote directory. *)
defaults.remote_directory = None;
+ ask_network, (* Network configuration. *)
+ defaults.network = None;
ask_devices, (* Block devices to send. *)
defaults.devices_to_send = None;
ask_root, (* Root filesystem. *)
defaults.root_filesystem = None;
- ask_network, (* Network configuration. *)
- defaults.network = None;
+ ask_hypervisor, (* Hypervisor. *)
+ defaults.hypervisor = None;
+ ask_architecture, (* Architecture. *)
+ defaults.architecture = None;
+ ask_memory, (* Memory. *)
+ defaults.memory = None;
+ ask_vcpus, (* VCPUs. *)
+ defaults.vcpus = None;
+ ask_mac_address, (* MAC address. *)
+ defaults.mac_address = None;
ask_verify, (* Verify settings. *)
- defaults.greeting*)
+ defaults.greeting
|] in
(* Loop through the dialogs until we reach the end. *)
(* Skip this dialog and move straight to the next one. *)
loop (posn+1) state
else (
- (* Run dialog. Either the state is updated or 'None' is
- * returned, which indicates that the user hit the back button.
- *)
- let next_state = dlg state in
- match next_state with
- | Some state -> loop (posn+1) state (* Forwards. *)
- | None -> loop (posn-1) state (* Backwards. *)
+ (* Run dialog. *)
+ match dlg state with
+ | Next new_state -> loop (posn+1) new_state (* Forwards. *)
+ | Prev -> loop (posn-1) state (* Backwards / back button. *)
+ | Ask_again -> loop posn state (* Repeat the question. *)
)
)
in
eprintf "finished dialog loop\n%!";
+ (* Check that the environment is a sane-looking live CD. If not, bail. *)
+ if is_dir "/mnt/root" <> Some true then
+ fail_dialog "You should only run this script from the live CD or a USB key.";
+ (* Switch LVM config. *)
+ sh "vgchange -a n";
+ putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
+ sh "rm -f /etc/lvm/cache/.cache";
+ sh "rm -f /etc/lvm.new/cache/.cache";
+ (* Snapshot the block devices to send. *)
+ let devices_to_send = Option.get state.devices_to_send in
+ let devices_to_send =
+ List.map (
+ fun origin_dev ->
+ let snapshot_dev = snapshot_name origin_dev in
+ snapshot origin_dev snapshot_dev;
+ (origin_dev, snapshot_dev)
+ ) devices_to_send in
+ (* Run kpartx on the snapshots. *)
+ List.iter (
+ fun (origin, snapshot) ->
+ shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
+ ) devices_to_send;
+ (* Rescan for LVs. *)
+ sh "vgscan";
+ sh "vgchange -a y";
- ()
+ (* Mount the root filesystem under /mnt/root. *)
+ let root_filesystem = Option.get state.root_filesystem in
+ (match root_filesystem with
+ | Part (dev, partnum) ->
+ let dev = dev ^ partnum in
+ let snapshot_dev = snapshot_name dev in
+ sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
-(* Run the external 'dialog' command with the given list of parameters.
- * Actually it's a list-of-list-of-parameters because you would normally
- * use this function like this:
- * dialog [
- * title (* title and other common parameters *) ();
- * dialogtype (* specific parameter *)
- * ]
- * where 'dialogtype' is a function such as 'msgbox' (see below)
- * representing a specific subfunction of dialog.
- *
- * The functions 'title' and 'dialogtype' return partially-constructed
- * lists of shell parameters. See the dialog manpage.
- *
- * Returns the exit status (Yes | No | Help | Extra | Error).
- *)
-and dialog params =
- let params = List.concat params in (* list-of-list to flat list *)
- let params = List.map Filename.quote params in (* shell quoting *)
- let cmd = String.concat " " ("dialog" :: params) in
- eprintf "%s\n%!" cmd; (* log the full command *)
- let r = Sys.command cmd in
- match r with
- | 0 -> Yes | 1 -> No | 2 -> Help | 3 -> Extra | _ -> Error
-
-(* Title and common dialog options. *)
-and title title ?(cancel=true) ?(backbutton=false) () =
- 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
- params
-
-(* Message box. *)
-and msgbox text height width =
- [ "--msgbox"; text; string_of_int height; string_of_int width ]
-
-and inputbox text height width default =
- [ "--inputbox"; text; string_of_int height; string_of_int width; default ]
-
-and radiolist 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
- "--radiolist" :: text :: string_of_int height :: string_of_int width ::
- string_of_int listheight :: items
+ | LV (vg, lv) ->
+ (* The LV will be backed by a snapshot device, so just mount
+ * directly.
+ *)
+ sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
+ );
+
+ (* See if we can do network configuration. *)
+ let network = Option.get state.network in
+ (match network with
+ | Shell ->
+ printf "Network configuration.\n\n";
+ printf "Please configure the network from this shell.\n\n";
+ printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
+ shell ()
+
+ | Auto ->
+ printf
+ "Trying network auto-configuration from root filesystem ...\n\n%!";
+ if not (auto_network state) then (
+ printf "\nAuto-configuration failed. Starting a shell.\n\n";
+ printf "Please configure the network from this shell.\n\n";
+ printf "When you have finished, exit the shell with ^D or exit.\n\n";
+ shell ()
+ )
+ );
+
+ (* Work out what devices will be called at the remote end. *)
+ let devices_to_send = List.map (
+ fun (origin_dev, snapshot_dev) ->
+ let remote_dev = remote_of_origin_dev origin_dev in
+ (origin_dev, snapshot_dev, remote_dev)
+ ) devices_to_send in
+
+ (* Modify files on the root filesystem. *)
+ rewrite_fstab state devices_to_send;
+ (* XXX Other files to rewrite? *)
+
+ (* XXX Autodetect architecture of root filesystem by looking for /bin/ls. *)
+ let system_architecture = "x86_64" in
+
+ (* XXX Autodetect system memory. *)
+ let system_memory = 256 in
+
+ (* XXX Autodetect system # pCPUs. *)
+ let system_nr_cpus = 1 in
+
+ (* Unmount the root filesystem and sync disks. *)
+ sh "umount /mnt/root";
+ sh "sync"; (* Ugh, should be in stdlib. *)
+
+ (* Disable screen blanking on console. *)
+ sh "setterm -blank 0";
+
+ let remote_host = Option.get state.remote_host in
+ let remote_port = Option.get state.remote_port in
+ let remote_directory = Option.get state.remote_directory in
+ let transport = Option.get state.transport in
+
+ (* Connect and disconnect from the remote system. *)
+ let do_connect, do_disconnect =
+ match transport with
+ | Server ->
+ let do_connect remote_name size =
+ let addrs =
+ getaddrinfo remote_host remote_port [AI_SOCKTYPE SOCK_STREAM] in
+ let rec loop = function
+ | [] ->
+ fail_dialog
+ (sprintf "Unable to connect to %s:%s" remote_host remote_port)
+ | addr :: addrs ->
+ try
+ let sock =
+ socket addr.ai_family addr.ai_socktype addr.ai_protocol in
+ connect sock addr.ai_addr;
+ let header = sprintf "p2v2 %s %Ld\n%!" remote_name size in
+ let len = String.length header in
+ assert (len = write sock header 0 len);
+ sock
+ with Unix_error (err, syscall, extra) ->
+ (* Log the error message, but continue around the loop. *)
+ eprintf "%s:%s: %s\n%!" syscall extra (error_message err);
+ loop addrs
+ in
+ loop addrs
+ in
+ let do_disconnect sock = close sock in
+ do_connect, do_disconnect
+ | SSH ->
+ (* Cheat by keeping a private variable around containing the original
+ * channel, so we can close it easily. (XXX)
+ *)
+ let chan = ref None in
+ let do_connect remote_name _ =
+ let cmd = sprintf "ssh -C -p %s %s \"cat > %s/%s\""
+ (quote remote_port) (quote remote_host)
+ (quote remote_directory) (quote remote_name) in
+ let c = open_process_out cmd in
+ chan := Some c;
+ descr_of_out_channel c
+ in
+ let do_disconnect _ =
+ (match close_process_out (Option.get !chan) with
+ | WEXITED 0 -> () (* OK *)
+ | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
+ | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
+ | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
+ );
+ chan := None
+ in
+ do_connect, do_disconnect in
+
+ (* XXX This is using the hostname derived from network configuration
+ * above. We might want to ask the user to choose.
+ *)
+ let hostname = safe_name (gethostname ()) in
+ let basename =
+ let date = sprintf "%04d%02d%02d%02d%02d"
+ (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
+ "p2v-" ^ hostname ^ "-" ^ date in
+
+ (* Work out what the image filenames will be at the remote end. *)
+ let devices_to_send = List.map (
+ fun (origin_dev, snapshot_dev, remote_dev) ->
+ let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
+ (origin_dev, snapshot_dev, remote_dev, remote_name)
+ ) devices_to_send in
+
+ (* Write a configuration file. Not sure if this is any better than
+ * just 'sprintf-ing' bits of XML text together, but at least we will
+ * always get well-formed XML.
+ *
+ * XXX For some of the stuff here we really should do a
+ * virConnectGetCapabilities call to the remote host first.
+ *
+ * XXX There is a case for using virt-install to generate this XML.
+ * When we start to incorporate libvirt access & storage API this
+ * needs to be rethought.
+ *)
+ let conf_filename = basename ^ ".conf" in
+
+ let architecture =
+ match state.architecture with
+ | Some "" | None -> system_architecture
+ | Some arch -> arch in
+ let memory =
+ match state.memory with
+ | Some memory -> memory
+ | None -> system_memory in
+ let vcpus =
+ match state.vcpus with
+ | Some 0 | None -> system_nr_cpus
+ | Some n -> n in
+ let mac_address =
+ match state.mac_address with
+ | Some "" | None ->
+ let random =
+ List.map (sprintf "%02x") (
+ List.map (fun _ -> Random.int 256) [0;0;0]
+ ) in
+ String.concat ":" ("00"::"16"::"3e"::random)
+ | Some mac -> mac in
+
+ let xml =
+ (* Shortcut to make "<name>value</name>". *)
+ let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
+ (* ... and the _other_ sort of leaf (god I hate XML). *)
+ let tleaf name attribs = Xml.Element (name, attribs, []) in
+
+ (* Standard stuff for every domain. *)
+ let name = leaf "name" hostname in
+ let memory = leaf "memory" (string_of_int (memory * 1024)) in
+ let vcpu = leaf "vcpu" (string_of_int vcpus) in
+
+ (* Top-level stuff which differs for each HV type (isn't this supposed
+ * to be portable ...)
+ *)
+ let extras =
+ match state.hypervisor with
+ | Some Xen ->
+ [Xml.Element ("os", [],
+ [leaf "type" "hvm";
+ leaf "loader" "/usr/lib/xen/boot/hvmloader";
+ tleaf "boot" ["dev", "hd"]]);
+ Xml.Element ("features", [],
+ [tleaf "pae" [];
+ tleaf "acpi" [];
+ tleaf "apic" []]);
+ tleaf "clock" ["sync", "localtime"]]
+ | Some KVM ->
+ [Xml.Element ("os", [], [leaf "type" "hvm"]);
+ tleaf "clock" ["sync", "localtime"]]
+ | Some QEMU ->
+ [Xml.Element ("os", [],
+ [Xml.Element ("type", ["arch",architecture;
+ "machine","pc"],
+ [Xml.PCData "hvm"]);
+ tleaf "boot" ["dev", "hd"]])]
+ | None ->
+ [] in
+
+ (* <devices> section. *)
+ let devices =
+ let emulator =
+ match state.hypervisor with
+ | Some Xen ->
+ [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
+ | Some QEMU ->
+ [leaf "emulator" "/usr/bin/qemu"]
+ | Some KVM ->
+ [leaf "emulator" "/usr/bin/qemu-kvm"]
+ | None ->
+ [] in
+ let interface =
+ Xml.Element ("interface", ["type", "user"],
+ [tleaf "mac" ["address", mac_address]]) in
+ (* XXX should have an option for Xen bridging:
+ Xml.Element (
+ "interface", ["type","bridge"],
+ [tleaf "source" ["bridge","xenbr0"];
+ tleaf "mac" ["address",mac_address];
+ tleaf "script" ["path","vif-bridge"]])*)
+ let graphics = tleaf "graphics" ["type", "vnc"] in
+
+ let disks = List.map (
+ fun (_, _, remote_dev, remote_name) ->
+ Xml.Element (
+ "disk", ["type", "file";
+ "device", "disk"],
+ [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
+ tleaf "target" ["dev", remote_dev]]
+ )
+ ) devices_to_send in
+
+ Xml.Element (
+ "devices", [],
+ emulator @ interface :: graphics :: disks
+ ) in
+
+ (* Put it all together in <domain type='foo'>. *)
+ Xml.Element (
+ "domain",
+ (match state.hypervisor with
+ | Some Xen -> ["type", "xen"]
+ | Some QEMU -> ["type", "qemu"]
+ | Some KVM -> ["type", "kvm"]
+ | None -> []),
+ name :: memory :: vcpu :: extras @ [devices]
+ ) in
+
+ let xml = Xml.to_string_fmt xml in
+ let xml_len = String.length xml in
+ eprintf "length of configuration file is %d bytes\n%!" xml_len;
+
+ let sock = do_connect conf_filename (Int64.of_int xml_len) in
+ (* In OCaml this actually loops calling write(2) *)
+ ignore (write sock xml 0 xml_len);
+ do_disconnect sock;
+
+ (* Send the device snapshots to the remote host. *)
+ (* XXX This code should be made more robust against both network
+ * errors and local I/O errors. Also should allow the user several
+ * attempts to connect, or let them go back to the dialog stage.
+ *)
+ List.iter (
+ fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
+ eprintf "sending %s as %s\n%!" origin_dev remote_name;
+
+ let size =
+ try List.assoc origin_dev all_block_devices
+ with Not_found -> assert false (* internal error *) in
+
+ printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
+ ((Int64.to_float size) /. (1024.*.1024.*.1024.));
+
+ (* Open the snapshot device. *)
+ let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
+
+ (* Now connect. *)
+ let sock = do_connect remote_name size in
+
+ (* Copy the data. *)
+ let bufsize = 1024 * 1024 in
+ let buffer = String.create bufsize in
+ let start = gettimeofday () in
+
+ let rec copy bytes_sent last_printed_at =
+ let n = read fd buffer 0 bufsize in
+ if n > 0 then (
+ ignore (write sock buffer 0 n);
+
+ let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
+ let last_printed_at =
+ let now = gettimeofday () in
+ (* Print progress once per second. *)
+ if now -. last_printed_at > 1. then (
+ let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
+ let secs_elapsed = now -. start in
+ printf "%.0f%%" (100. *. elapsed);
+ (* After 60 seconds has elapsed, start printing estimates. *)
+ if secs_elapsed >= 60. then (
+ let remaining = 1. -. elapsed in
+ let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
+ if secs_remaining > 120. then
+ printf " (about %.0f minutes remaining) "
+ (secs_remaining /. 60.)
+ else
+ printf " (about %.0f seconds remaining) "
+ secs_remaining
+ );
+ printf "\r%!";
+ now
+ )
+ else last_printed_at in
+
+ copy bytes_sent last_printed_at
+ )
+ in
+ copy 0L start;
+
+ (* Disconnect. *)
+ do_disconnect sock
+ ) devices_to_send;
+
+ (* Clean up and reboot. *)
+ ignore (
+ msgbox "virt-p2v completed"
+ (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."
+ remote_directory conf_filename)
+ 17 50
+ );
+
+ shfailok "eject";
+ shfailok "reboot";
+ exit 0
let usage () =
eprintf "usage: virt-p2v [ttyname]\n%!";
exit 2
+(* Make sure that exceptions from 'main' get printed out on stdout
+ * as well as stderr, since stderr is probably redirected to the
+ * logfile, and so not visible to the user.
+ *)
+let handle_exn f arg =
+ try f arg
+ with exn -> print_endline (Printexc.to_string exn); raise exn
+
+(* If the ISO image has an attachment then it could be a new version
+ * of virt-p2v.ml (this script). Get the attachment and run it
+ * instead. Useful mainly for testing, in conjunction with the
+ * 'make update' target in the virt-p2v Makefile.
+ *)
+let magic = "ISOATTACHMENT002"
+let magiclen = String.length magic (* = 16 bytes *)
+let trailerlen = magiclen + 8 + 8 (* magic + file start + true size *)
+
+let int64_of_string str =
+ let i = ref 0L in
+ let add offs shift =
+ i :=
+ Int64.logor
+ (Int64.shift_left (Int64.of_int (Char.code str.[offs])) shift) !i
+ in
+ add 0 56; add 1 48; add 2 40; add 3 32;
+ add 4 24; add 5 16; add 6 8; add 7 0;
+ !i
+
+let update ttyname =
+ let cdrom = "/dev/cdrom" in
+ let output = "/tmp/virt-p2v.ml" in
+
+ try
+ let fd = openfile cdrom [O_RDONLY] 0 in
+ ignore (LargeFile.lseek fd (Int64.of_int ~-trailerlen) SEEK_END);
+ let buf = String.create magiclen in
+ if read fd buf 0 magiclen <> magiclen || buf <> magic then (
+ close fd;
+ raise Exit
+ );
+
+ (* Read the size. *)
+ let buf = String.create 8 in
+ if read fd buf 0 8 <> 8 then
+ failwith "cannot read attachment offset";
+ let offset = int64_of_string buf in
+ let buf = String.create 8 in
+ if read fd buf 0 8 <> 8 then
+ failwith "cannot read attachment size";
+ let size = Int64.to_int (int64_of_string buf) in
+
+ (* Seek to beginning of the attachment. *)
+ ignore (LargeFile.lseek fd offset SEEK_SET);
+
+ (* Copy out the attachment. *)
+ let fd2 = openfile output [O_WRONLY; O_CREAT; O_TRUNC] 0o755 in
+ let bufsize = 4 * 1024 in
+ let buffer = String.create bufsize in
+ let rec copy remaining =
+ if remaining > 0 then (
+ let n = min remaining bufsize in
+ let n = read fd buffer 0 n in
+ if n = 0 then failwith "corrupted or partial attachment";
+ ignore (write fd2 buffer 0 n);
+ copy (remaining - n)
+ )
+ in
+ copy size;
+ close fd2;
+
+ close fd;
+
+ (* Run updated virt-p2v script. *)
+ execv output [| output; ttyname |]
+ with
+ Unix_error _ | Exit ->
+ (* Some error, or no attachment, so keep running this script. *)
+ handle_exn main (Some ttyname)
+
(* Test harness for the Makefile. The Makefile invokes this script as
* 'virt-p2v.ml --test' just to check it compiles. When it is running
* from the actual live CD, there is a single parameter which is the
*)
let () =
match Array.to_list Sys.argv with
- | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
+ | [ _; "--test" ] -> () (* Makefile test - do nothing. *)
+ | [ _; "--update"; ttyname ] -> (* Test for update and run. *)
+ update ttyname
| [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
- | [ _; ttyname ] -> main (Some ttyname) (* Run main with ttyname. *)
- | [ _ ] -> main None (* Interactive - no ttyname. *)
+ | [ _; ttyname ] -> (* Run main with ttyname. *)
+ handle_exn main (Some ttyname)
+ | [ _ ] -> (* Interactive - no ttyname. *)
+ handle_exn main None
| _ -> usage ()
+
+(* This file must end with a newline *)