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 : partition option }
-and transport = SSH | TCP
+and transport = Server | SSH | TCP
and network = Auto | Shell
and partition = Part of string * string (* eg. "hda", "1" *)
| LV of string * string (* eg. "VolGroup00", "LogVol00" *)
*)
greeting = true;
- (* Transport: Set to 'Some SSH' or 'Some TCP' to assume SSH or TCP
- * respectively.
+ (* Transport: Set to 'Some Server' or 'Some SSH' or 'Some TCP' to
+ * assume Server, SSH or TCP transports respectively.
*)
- remote_transport = None;
+ transport = None;
(* Remote host and port. Set to 'Some "host"' and 'Some "port"',
* else ask the user.
* automatically, or 'Some Shell' (give the user a shell).
*)
network = None;
-
}
(* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
(*----------------------------------------------------------------------*)
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 rec string_of_state state =
sprintf
"greeting: %b remote: %s:%s%s%s network: %s devices: [%s] root: %s"
state.greeting
(Option.default "" state.remote_host)
(Option.default "" state.remote_port)
- (match state.remote_transport with
- | None -> "" | Some SSH -> " (ssh)" | Some TCP -> " (tcp)")
+ (match state.transport with
+ | None -> ""
+ | Some Server -> " (server)" | Some SSH -> " (ssh)" | Some TCP -> " (tcp)")
(match state.remote_directory with
| None -> "" | Some dir -> " " ^ dir)
(match state.network with
type ask_result = Next of state | Prev | Ask_again
-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
-
-(* Same as `cmd` in shell. Any error message will be in the logfile. *)
-let shget 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)
-
-let is_dir path = (stat path).st_kind = S_DIR
-
-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 whitespace = Pcre.regexp "[ \t]+" in
- let comma = Pcre.regexp "," in
- 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 = Pcre.split ~rex:comma pvs in
- let pvs = List.map (
- fun pv ->
- try
- let subs = Pcre.exec ~rex:devname pv in
- Pcre.get_substring subs 1
- with
- Not_found -> failwith ("lvs: unexpected device name: " ^ pv)
- ) 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 -> 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
-
(* Dialog functions.
*
* Each function takes some common parameters (eg. ~title) and some
*
* Returns the exit status (Yes lines | No | Help | Back | Error).
*)
-let msgbox, inputbox, radiolist, checklist =
+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));
+ 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.
cont params
in
- (* Message box. *)
- let msgbox =
+ (* 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 ]
)
- in
+ 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. *)
- let inputbox =
+ and inputbox =
with_common (
fun cparams text height width default ->
run_dialog cparams
[ "--inputbox"; text; string_of_int height; string_of_int width;
default ]
)
- in
(* Radio list and check list. *)
- let radiolist =
+ and radiolist =
with_common (
fun cparams text height width listheight items ->
let items = List.map (
string_of_int listheight :: items in
run_dialog cparams items
)
- in
-
- let checklist =
+ and checklist =
with_common (
fun cparams text height width listheight items ->
let items = List.map (
run_dialog cparams items
)
in
- msgbox, inputbox, radiolist, checklist
+ msgbox, yesno, inputbox, radiolist, checklist
(* Print failure dialog and exit. *)
let fail_dialog text =
- let text = 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
+ 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 "shfailok: %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.map (
+ fun pv ->
+ try
+ let subs = Pcre.exec ~rex:devname pv in
+ Pcre.get_substring subs 1
+ with
+ Not_found -> failwith ("lvs: unexpected device name: " ^ pv)
+ ) 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. *)
+ sh ("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
*)
let devices = List.filter_map (
fun d ->
- let cmd = "blockdev --getsize64 /dev/" ^ Filename.quote d in
+ let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
let lines = shget cmd in
match lines with
| Some (blksize::_) -> Some (d, Int64.of_string blksize)
let ask_transport state =
match
radiolist "Connection type" ~backbutton:false
- "Connection type" 10 50 2 [
- "ssh", "SSH (secure shell - recommended)",
- state.remote_transport = Some SSH;
+ "Connection type. If possible, select 'server' and run P2V server on the remote host"
+ 10 50 2 [
+ "server", "P2V server on remote host",
+ state.transport = Some Server;
+ "ssh", "SSH (secure shell)",
+ state.transport = Some SSH;
"tcp", "TCP socket",
- state.remote_transport = Some TCP
+ state.transport = Some TCP
]
with
- | Yes ("ssh"::_) -> Next { state with remote_transport = Some SSH }
- | Yes ("tcp"::_) -> Next { state with remote_transport = Some TCP }
+ | Yes ("server"::_) -> Next { state with transport = Some Server }
+ | Yes ("ssh"::_) -> Next { state with transport = Some SSH }
+ | Yes ("tcp"::_) -> Next { state with transport = Some TCP }
| Yes _ | No | Help | Error -> Ask_again
| Back -> Prev
in
(Option.default "" state.remote_port)
with
| Yes [] ->
- if state.remote_transport = Some TCP then
- Next { state with remote_port = Some "16211" }
- else
- Next { state with remote_port = Some "22" }
+ (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
| 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
+Remote host: %s
+Remote port: %s
+Directory: %s
+Network: %s
+Send devices: %s
+Root (/) dev: %s"
+ (match state.transport with
+ | Some Server -> "Server"
+ | Some SSH -> "SSH" | Some TCP -> "TCP socket"
+ | 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))
+ 18 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
* backwards through them. The second parameter in each pair is
* false if we need to skip this dialog (info already supplied in
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.devices_to_send = None;
ask_root, (* Root filesystem. *)
defaults.root_filesystem = None;
-(* ask_verify, (* Verify settings. *)
- defaults.greeting*)
+ ask_verify, (* Verify settings. *)
+ defaults.greeting
|] in
(* Loop through the dialogs until we reach the end. *)
in
let state = loop 0 defaults in
- eprintf "finished dialog loop\nstate = %s\n%!" (string_of_state state);
-
-
-
-
-
-
- ()
+ eprintf "finished dialog loop\nfinal state = %s\n%!" (string_of_state state);
+
+ (* Check that the environment is a sane-looking live CD. If not, bail. *)
+ if is_dir "/mnt/root" <> Some true ||
+ is_file "/etc/lvm/lvm.conf.new" <> 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";
+ sh "mv /etc/lvm/lvm.conf /etc/lvm/lvm.conf.old";
+ sh "mv /etc/lvm/lvm.conf.new /etc/lvm/lvm.conf";
+ sh "rm -f /etc/lvm/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")
+
+ | 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
+
+ rewrite_fstab state devices_to_send;
+ (* XXX Other files to rewrite? *)
+
+ (* Unmount the root filesystem and sync disks. *)
+ sh "umount /mnt/root";
+ sh "sync"; (* Ugh, should be in stdlib. *)
+
+ (* For Server and TCP type connections, we connect just once. *)
+ 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
+
+ let sock =
+ match transport with
+ | Server | TCP ->
+ 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;
+ 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
+ | SSH ->
+ (* Just dummy socket for SSH for now ... *) stdin in
+
+ (* Send the device snapshots to the remote host. *)
+ (* XXX This is using the hostname derived from network configuration
+ * above. We might want to ask the user to choose.
+ *)
+ let basename =
+ let hostname = safe_name (gethostname ()) in
+ 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
+
+ (* 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) ->
+ let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
+ 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 (for SSH) or send the header (for Server/TCP). *)
+ let sock, chan =
+ match transport with
+ | Server | TCP ->
+ 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, Pervasives.stdout
+ | SSH ->
+ 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 chan = open_process_out cmd in
+ let fd = descr_of_out_channel chan in
+ fd, chan in
+
+ (* Copy the data. *)
+ let bufsize = 128 * 1024 in
+ let buffer = String.create bufsize in
+
+ let rec copy () =
+ let n = read fd buffer 0 bufsize in
+ if n > 0 then (
+ ignore (write sock buffer 0 n);
+ copy ()
+ )
+ in
+ copy ();
+
+ (* For SSH disconnect, for Server/TCP send a newline. *)
+ match transport with
+ | Server | TCP ->
+ ignore (write sock "\n" 0 1)
+ | SSH ->
+ match close_process_out 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)
+ ) devices_to_send;
+
+ (* Disconnect. *)
+ (match transport with
+ | Server | TCP -> close sock
+ | SSH -> ()
+ );
+
+ (* XXX Write a configuration file. *)
+ let conf_filename = basename ^ ".conf" in
+
+ (* 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\nvirsh define %s/%s\n\nWhen you press [OK] this machine will reboot."
+ (Option.default "" state.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
+
(* 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. *)
| [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
- | [ _; ttyname ] -> main (Some ttyname) (* Run main with ttyname. *)
- | [ _ ] -> main None (* Interactive - no ttyname. *)
+ | [ _; ttyname ] ->
+ handle_exn main (Some ttyname) (* Run main with ttyname. *)
+ | [ _ ] ->
+ handle_exn main None (* Interactive - no ttyname. *)
| _ -> usage ()
git.annexia.org / virt-p2v.git / commitdiff