X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=virt-p2v.ml;h=23b59f0ad1e0d8c457354c28f1b137ca6e4695ef;hb=e3ee0ffbe935690a7caf6d2972d23af58650ae24;hp=a6ff2f0752bbb959aa532ba84f5a174077715a5f;hpb=c9a5484137679f73da4d6ddff80bee05d815b3fb;p=virt-p2v.git diff --git a/virt-p2v.ml b/virt-p2v.ml index a6ff2f0..23b59f0 100755 --- a/virt-p2v.ml +++ b/virt-p2v.ml @@ -35,21 +35,21 @@ open ExtString type state = { greeting : bool; remote_host : string option; remote_port : string option; - transport : transport option; remote_directory : string option; network : network option; devices_to_send : string list option; root_filesystem : partition option; hypervisor : hypervisor option; - architecture : string option; + architecture : architecture option; memory : int option; vcpus : int option; mac_address : string option; } -and transport = Server | SSH and network = Auto | Shell and partition = Part of string * string (* eg. "hda", "1" *) | LV of string * string (* eg. "VolGroup00", "LogVol00" *) and hypervisor = Xen | QEMU | KVM +and architecture = I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64 + | OtherArch of string | UnknownArch (*----------------------------------------------------------------------*) (* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section. @@ -68,19 +68,14 @@ let defaults = { *) greeting = true; - (* Transport: Set to 'Some Server' or 'Some SSH' to assume Server or SSH - * transports respectively. - *) - transport = None; - (* Remote host and port. Set to 'Some "host"' and 'Some "port"', * else ask the user. *) remote_host = None; remote_port = None; - (* Remote directory (only for SSH transport). Set to 'Some "path"' - * to set up a directory path, else ask the user. + (* Remote directory. Set to 'Some "path"' to set up a + * directory path, else ask the user. *) remote_directory = None; @@ -103,8 +98,9 @@ let defaults = { (* 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: Set to 'Some X86_64' (or another architecture). + * If set to 'Some UnknownArch' then we try to autodetect the + * right architecture. *) architecture = None; @@ -150,10 +146,46 @@ let dev_of_partition = function | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv +let string_of_architecture = function + | I386 -> "i386" + | X86_64 -> "x86_64" + | IA64 -> "ia64" + | PPC -> "ppc" + | PPC64 -> "ppc64" + | SPARC -> "sparc" + | SPARC64 -> "sparc64" + | OtherArch arch -> arch + | UnknownArch -> "" + type dialog_status = Yes of string list | No | Help | Back | Error type ask_result = Next of state | Prev | Ask_again +type nature = LinuxSwap + | LinuxRoot of architecture * linux_distro + | WindowsRoot (* Windows C: *) + | LinuxBoot (* Linux /boot *) + | NotRoot (* mountable, but not / or /boot *) + | UnknownNature +and linux_distro = RHEL of int * int + | Fedora of int + | Debian of int * int + | OtherLinux + +let rec string_of_nature = function + | LinuxSwap -> "Linux swap" + | LinuxRoot (architecture, distro) -> + string_of_linux_distro distro ^ " " ^ string_of_architecture architecture + | WindowsRoot -> "Windows root" + | LinuxBoot -> "Linux /boot" + | NotRoot -> "Mountable non-root" + | UnknownNature -> "Unknown" +and string_of_linux_distro = function + | RHEL (a,b) -> sprintf "RHEL %d.%d" a b + | Fedora v -> sprintf "Fedora %d" v + | Debian (a,b) -> sprintf "Debian %d.%d" a b + | OtherLinux -> "Linux" + (* Dialog functions. * * Each function takes some common parameters (eg. ~title) and some @@ -293,9 +325,21 @@ let shget cmd = | 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. *) +(* Start an interactive shell. Need to juggle file descriptors a bit + * because bash write PS1 to stderr (currently directed to the logfile). + *) let shell () = - shfailok "PS1='\\u@\\h:\\w\\$ ' bash" + match fork () with + | 0 -> (* child, runs bash *) + close stderr; + dup2 stdout stderr; + (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *) + ignore ( + Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i" + ) + | _ -> (* parent, waits *) + eprintf "waiting for subshell to exit\n%!"; + ignore (wait ()) (* Some true if is dir/file, Some false if not, None if not found. *) let is_dir path = @@ -409,35 +453,46 @@ let 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. +(* 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. +(* + (* We can run /mnt/root/etc/init.d/network in a chroot environment, + * however this won't work directly because the architecture of the + * binaries under /mnt/root (eg. /mnt/root/sbin/ip) might not match + * the architecture of the live CD kernel. In particular, a 32 bit + * live CD cannot run 64 bit binaries. So we also have to bind-mount + * the live CD's /bin, /sbin, /lib etc. over the equivalents in + * /mnt/root. *) - 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 bind dir = + if is_dir dir = Some true then + sh ("mount -o bind " ^ quote dir ^ " " ^ quote ("/mnt/root" ^ dir)) + in + let unbind dir = + if is_dir dir = Some true then sh ("umount -l " ^ quote ("/mnt/root" ^ dir)) + in + let dirs = [ + "/bin"; "/sbin"; "/lib"; "/lib64"; + "/usr/bin"; "/usr/sbin"; "/usr/lib"; "/usr/lib64"; + "/proc"; "/sys" + ] in + List.iter bind dirs; + let status = shwithstatus "chroot /mnt/root /etc/init.d/network start" in + List.iter unbind dirs; +*) + + (* Simpler way to do the above. + * NB. Lazy unmount is required because dhclient keeps its current + * directory open on /etc/sysconfig/network-scripts/ + *) + sh "mount -o bind /mnt/root/etc /etc"; 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"; + sh "umount -l /etc"; (* Try to ping the remote host to see if this worked. *) shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host); @@ -531,6 +586,13 @@ let rec main ttyname = close fd); printf "virt-p2v.ml starting up ...\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."; + + printf "virt-p2v.ml detecting hard drives (this may take some time) ...\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". *) @@ -597,27 +659,141 @@ let rec main ttyname = (* Concatenate LVs & Parts *) lvs @ parts in + (* Try to determine the nature of each partition. + * Root? Swap? Architecture? etc. + *) + let all_partitions : (partition * nature) list = + (* Output of 'file' command for Linux swap file. *) + let swap = Pcre.regexp "Linux.*swap.*file" in + (* Contents of /etc/redhat-release. *) + let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in + let fedora = Pcre.regexp "Fedora.*release (\\d+)" in + (* Contents of /etc/debian_version. *) + let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in + (* Output of 'file' on certain executables. *) + let i386 = Pcre.regexp ", Intel 80386," in + let x86_64 = Pcre.regexp ", x86-64," in + let itanic = Pcre.regexp ", IA-64," in + + (* Examine the filesystem mounted on 'mnt' to determine the + * operating system, and, if Linux, the distro. + *) + let detect_os mnt = + if is_dir (mnt ^ "/Windows") = Some true && + is_file (mnt ^ "/autoexec.bat") = Some true then + WindowsRoot + else if is_dir (mnt ^ "/etc") = Some true && + is_dir (mnt ^ "/sbin") = Some true && + is_dir (mnt ^ "/var") = Some true then ( + if is_file (mnt ^ "/etc/redhat-release") = Some true then ( + let chan = open_in (mnt ^ "/etc/redhat-release") in + let lines = input_all_lines chan in + close_in chan; + + match lines with + | [] -> (* empty /etc/redhat-release ...? *) + LinuxRoot (UnknownArch, OtherLinux) + | line::_ -> (* try to detect OS from /etc/redhat-release *) + try + let subs = Pcre.exec ~rex:rhel line in + let major = int_of_string (Pcre.get_substring subs 1) in + let minor = + try int_of_string (Pcre.get_substring subs 2) + with Not_found -> 0 in + LinuxRoot (UnknownArch, RHEL (major, minor)) + with + Not_found | Failure "int_of_string" -> + try + let subs = Pcre.exec ~rex:fedora line in + let version = int_of_string (Pcre.get_substring subs 1) in + LinuxRoot (UnknownArch, Fedora version) + with + Not_found | Failure "int_of_string" -> + LinuxRoot (UnknownArch, OtherLinux) + ) + else if is_file (mnt ^ "/etc/debian_version") = Some true then ( + let chan = open_in (mnt ^ "/etc/debian_version") in + let lines = input_all_lines chan in + close_in chan; + + match lines with + | [] -> (* empty /etc/debian_version ...? *) + LinuxRoot (UnknownArch, OtherLinux) + | line::_ -> (* try to detect version from /etc/debian_version *) + try + let subs = Pcre.exec ~rex:debian line in + let major = int_of_string (Pcre.get_substring subs 1) in + let minor = int_of_string (Pcre.get_substring subs 2) in + LinuxRoot (UnknownArch, Debian (major, minor)) + with + Not_found | Failure "int_of_string" -> + LinuxRoot (UnknownArch, OtherLinux) + ) + else + LinuxRoot (UnknownArch, OtherLinux) + ) else if is_dir (mnt ^ "/grub") = Some true && + is_file (mnt ^ "/grub/stage1") = Some true then ( + LinuxBoot + ) else + NotRoot (* mountable, but not a root filesystem *) + in + + (* Examine the Linux root filesystem mounted on 'mnt' to + * determine the architecture. We do this by looking at some + * well-known binaries that we expect to be there. + *) + let detect_architecture mnt = + let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in + match shget cmd with + | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386 + | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64 + | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64 + | _ -> UnknownArch + in + + List.map ( + fun part -> + let dev = dev_of_partition part in (* Get /dev device. *) + + let nature = + (* Use 'file' command to detect if it is swap. *) + let cmd = "file -sbL " ^ quote dev in + match shget cmd with + | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap + | _ -> + (* Blindly try to mount the device. *) + let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in + match shwithstatus cmd with + | 0 -> + let os = detect_os "/mnt/root" in + let nature = + match os with + | LinuxRoot (UnknownArch, distro) -> + let architecture = detect_architecture "/mnt/root" in + LinuxRoot (architecture, distro) + | os -> os in + sh "umount /mnt/root"; + nature + + | _ -> UnknownNature (* not mountable *) + + in + + eprintf "partition detection: %s is %s\n%!" + dev (string_of_nature nature); + + (part, nature) + ) all_partitions + in + + printf "virt-p2v.ml finished detecting hard drives\n%!"; + (* Dialogs. *) 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 @@ -632,25 +808,21 @@ let rec main ttyname = let ask_port state = match inputbox "Remote port" "Remote port" 10 50 - (Option.default "" state.remote_port) + (Option.default "22" 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 ([]|""::_) -> Next { state with remote_port = Some "22" } | Yes (port::_) -> Next { state with remote_port = Some port } | No | Help | Error -> Ask_again | Back -> Prev in let ask_directory state = + let default_dir = "/var/lib/xen/images" in match inputbox "Remote directory" "Remote directory" 10 50 - (Option.default "" state.remote_directory) + (Option.default default_dir state.remote_directory) with - | Yes [] -> - Next { state with remote_directory = Some "/var/lib/xen/images" } + | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir } | Yes (dir::_) -> Next { state with remote_directory = Some dir } | No | Help | Error -> Ask_again | Back -> Prev @@ -688,17 +860,29 @@ let rec main ttyname = let ask_root state = let parts = List.mapi ( - fun i part -> - (string_of_int i, dev_of_partition part, + fun i (part, nature) -> + let descr = + match nature with + | LinuxSwap -> " (Linux swap)" + | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b + | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v + | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b + | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)" + | WindowsRoot -> " (Windows C:)" + | LinuxBoot -> " (Linux /boot)" + | NotRoot -> " (filesystem)" + | UnknownNature -> "" in + (string_of_int i, + dev_of_partition part ^ descr, Some part = state.root_filesystem) ) all_partitions in match radiolist "Root device" - "Pick partition containing the root (/) filesystem" 15 50 6 + "Pick partition containing the root (/) filesystem" 18 70 9 parts with | Yes (i::_) -> - let part = List.nth all_partitions (int_of_string i) in + 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 @@ -726,19 +910,25 @@ let rec main ttyname = 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 "";*) + "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", "Auto-detect", + state.architecture = None || state.architecture = Some UnknownArch; ] with - | Yes (("auto"|"")::_ | []) -> Next { state with architecture = Some "" } - | Yes (arch :: _) -> Next { state with architecture = Some arch } + | Yes ("i386" :: _) -> Next { state with architecture = Some I386 } + | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 } + | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 } + | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC } + | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 } + | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC } + | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 } + | Yes _ -> Next { state with architecture = Some UnknownArch } | No | Help | Error -> Ask_again | Back -> Prev in @@ -791,7 +981,6 @@ let rec main ttyname = 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 @@ -802,9 +991,6 @@ 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) @@ -817,7 +1003,8 @@ MAC address: %s" | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM" | None -> "Other / not set") (match state.architecture with - | Some "" -> "Guess" | Some arch -> arch | None -> "") + | Some UnknownArch -> "Auto-detect" + | Some arch -> string_of_architecture arch | None -> "") (match state.memory with | Some 0 -> "Same as physical" | Some mem -> string_of_int mem ^ " MB" | None -> "") @@ -842,8 +1029,6 @@ MAC address: %s" let dlgs = [| ask_greeting, (* Initial greeting. *) defaults.greeting; - ask_transport, (* Transport (ssh, tcp) *) - defaults.transport = None; ask_hostname, (* Hostname. *) defaults.remote_host = None; ask_port, (* Port number. *) @@ -893,10 +1078,6 @@ MAC address: %s" 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) *) @@ -970,7 +1151,7 @@ MAC address: %s" (* XXX Other files to rewrite? *) (* XXX Autodetect architecture of root filesystem by looking for /bin/ls. *) - let system_architecture = "x86_64" in + let system_architecture = X86_64 in (* XXX Autodetect system memory. *) let system_memory = 256 in @@ -988,60 +1169,23 @@ MAC address: %s" 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 + + (* Functions to connect and disconnect from the remote system. *) + 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 + eprintf "connect: %s\n%!" cmd; + let chan = open_process_out cmd in + descr_of_out_channel chan, chan + in + let do_disconnect (_, chan) = + 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) + in (* XXX This is using the hostname derived from network configuration * above. We might want to ask the user to choose. @@ -1074,7 +1218,7 @@ MAC address: %s" let architecture = match state.architecture with - | Some "" | None -> system_architecture + | Some UnknownArch | None -> system_architecture | Some arch -> arch in let memory = match state.memory with @@ -1125,8 +1269,10 @@ MAC address: %s" tleaf "clock" ["sync", "localtime"]] | Some QEMU -> [Xml.Element ("os", [], - [Xml.Element ("type", ["arch",architecture; - "machine","pc"], + [Xml.Element ("type", + ["arch", + string_of_architecture architecture; + "machine","pc"], [Xml.PCData "hvm"]); tleaf "boot" ["dev", "hd"]])] | None -> @@ -1185,10 +1331,10 @@ MAC address: %s" 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 + let (sock,_) as conn = 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; + do_disconnect conn; (* Send the device snapshots to the remote host. *) (* XXX This code should be made more robust against both network @@ -1210,7 +1356,7 @@ MAC address: %s" let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in (* Now connect. *) - let sock = do_connect remote_name size in + let (sock,_) as conn = do_connect remote_name size in (* Copy the data. *) let bufsize = 1024 * 1024 in @@ -1252,7 +1398,7 @@ MAC address: %s" copy 0L start; (* Disconnect. *) - do_disconnect sock + do_disconnect conn ) devices_to_send; (* Clean up and reboot. *)