#!/usr/bin/ocamlrun /usr/bin/ocaml (* -*- tuareg -*- *) (* virt-p2v is a script which performs a physical to * virtual conversion of local disks. * * Copyright (C) 2007-2008 Red Hat Inc. * Written by Richard W.M. Jones * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type transfer = | P2V (* physical to virtual *) | V2V (* virtual to virtual *) (*| V2P*) (* virtual to physical - not impl *) type block_device = | HD of string (* eg. HD "a" for /dev/hda *) | SD of string (* eg. SD "b" for /dev/sdb *) | CCISS of int * int (* eg. CCISS (0,0) for /dev/cciss/c0d0*) type partition = | Part of block_device * string (* eg. (HD "a", "1") or (CCISS (0,0), "p1") *) | LV of string * string (* eg. ("VolGroup00", "LogVol00") *) type network = | Auto of partition (* Automatic network configuration. *) | Shell (* Start a shell. *) | QEMUUserNet (* Assume we're running under qemu. *) | Static of string * string * string * string * string (* interface, address, netmask, gateway, nameserver *) | NoNetwork type ssh_config = { ssh_host : string; (* Remote host for SSH. *) ssh_port : string; (* Remote port. *) ssh_directory : string; (* Remote directory. *) ssh_username : string; (* Remote username. *) ssh_compression : bool; (* If true, use SSH compression. *) ssh_check : bool; (* If true, check SSH is working. *) } type hypervisor = | Xen | QEMU | KVM type architecture = | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64 | OtherArch of string | UnknownArch type target_config = { tgt_hypervisor : hypervisor option; (* Remote hypervisor. *) tgt_architecture : architecture; (* Remote architecture. *) tgt_memory : int; (* Memory (megabytes). *) tgt_vcpus : int; (* Number of virtual CPUs. *) tgt_mac_address : string; (* MAC address. *) tgt_libvirtd : bool; (* True if libvirtd on remote. *) } (*----------------------------------------------------------------------*) (* TO MAKE A CUSTOM VIRT-P2V SCRIPT, adjust the defaults in this section. * * If left as they are, then this will create a generic virt-p2v script * which asks the user for each question. If you set the defaults here * then you will get a custom virt-p2v which is partially or even fully * automated and won't ask the user any questions. * * Note that 'None' means 'no default' (ie. ask the user) whereas * 'Some foo' means use 'foo' as the answer. * * These are documented in the virt-p2v(1) manual page. * * After changing them, run './virt-p2v --test' to check syntax. *) (* If greeting is true, wait for keypress after boot and during * final verification. Set to 'false' for less interactions. *) let config_greeting = ref true (* General type of transfer. *) let config_transfer_type = ref None (* Network configuration. *) let config_network = ref None (* SSH configuration. *) let config_ssh = ref None (* What to transfer. *) let config_devices_to_send = ref None (* The root filesystem - parts of this get modified after migration. *) let config_root_filesystem = ref None (* Configuration of the target. *) let config_target = ref None (* The name of the program as displayed in various places. *) let program_name = "virt-p2v" (* If you want to test the dialog stages, set this to true. *) let test_dialog_stages = false (* END OF CUSTOM virt-p2v SCRIPT SECTION. *) (*----------------------------------------------------------------------*) (* Load external libraries. *) ;; #use "topfind";; #require "extlib";; #require "pcre";; #require "newt";; #require "xml-light";; #require "gettext-stub";; #require "libvirt";; open Unix open Printf open ExtList open ExtString (*----------------------------------------------------------------------*) (* Gettext support. * * Use s_ "string" to mark a translatable string, and f_ "string %s" * to mark a format string (eg. for printf). There are other * functions: see ocaml-gettext manual and GNU gettext info. * * Try not to mark strings which always go to the log file (eg. * eprintf messages). *) module P2VGettext = Gettext.Program ( struct let textdomain = "virt-p2v" let codeset = None let dir = None let dependencies = [] end ) (GettextStub.Native) open P2VGettext let supported_langs = (* Note these strings are NOT translated! *) let nonasian_langs = [ "English", "en_US.UTF-8"; ] in let asian_langs = [ "\xE6\x97\xA5\xE6\x9C\xAC\xE8\xAA\x9E (Japanese)", "ja_JP.UTF-8" ] in (* Linux console doesn't support Asian or RTL languages. *) let term = try getenv "TERM" with Not_found -> "" in match term with | "linux" -> nonasian_langs | _ -> nonasian_langs @ asian_langs (*----------------------------------------------------------------------*) (* 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 (* eg. HD "a" => "hda", or CCISS (0,1) => "cciss/c0d1" *) let short_dev_of_block_device = function | HD n -> sprintf "hd%s" n | SD n -> sprintf "sd%s" n | CCISS (c, d) -> sprintf "cciss/c%dd%d" c d (* Returns the full /dev/ path to a block device. *) let dev_of_block_device dev = "/dev/" ^ short_dev_of_block_device dev (* Returns path to partition or LV without /dev/, * eg. "hda1" or "VolGroup/LogVol" *) let short_dev_of_partition = function | Part (dev, partnum) -> short_dev_of_block_device dev ^ partnum | LV (vg, lv) -> sprintf "%s/%s" vg lv (* Returns the full /dev/ path to a partition or LV. *) let dev_of_partition part = "/dev/" ^ short_dev_of_partition part (* A PV is loosely defined here as either a device or a partition - * basically anything that could be a PV. *) type pv = PVDev of block_device | PVPart of partition let string_of_pv = function | PVDev dev -> dev_of_block_device dev | PVPart p -> dev_of_partition p (* Take a device name optionally beginning with /dev/ and work * out if it looks like either a device or partition that we * know how to deal with. If not, returns None. * * For the sake of simplifying some code later on, the device * name may also be followed by "(\d+)" which is just ignored. *) let pv_of_dev = let hdp = Pcre.regexp "^/dev/hd([a-z]+)(\\d+)(\\(\\d+\\))?$" in let hd = Pcre.regexp "^/dev/hd([a-z]+)(\\(\\d\\))?$" in let sdp = Pcre.regexp "^/dev/sd([a-z]+)(\\d+)(\\(\\d+\\))?$" in let sd = Pcre.regexp "^/dev/sd([a-z]+)(\\(\\d+\\))?$" in let ccissp = Pcre.regexp "^/dev/cciss/c(\\d+)d(\\d+)(p\\d+)(\\(\\d+\\))?$" in let cciss = Pcre.regexp "^/dev/cciss/c(\\d+)d(\\d+)(\\(\\d+\\))?$" in let lv = Pcre.regexp "^/dev/(\\w+)/(\\w+)$" in fun name -> try let subs = Pcre.exec ~rex:hdp name in Some (PVPart (Part (HD (Pcre.get_substring subs 1), Pcre.get_substring subs 2))) with Not_found -> try let subs = Pcre.exec ~rex:hd name in Some (PVDev (HD (Pcre.get_substring subs 1))) with Not_found -> try let subs = Pcre.exec ~rex:sdp name in Some (PVPart (Part (SD (Pcre.get_substring subs 1), Pcre.get_substring subs 2))) with Not_found -> try let subs = Pcre.exec ~rex:sd name in Some (PVDev (SD (Pcre.get_substring subs 1))) with Not_found -> try let subs = Pcre.exec ~rex:ccissp name in let c = int_of_string (Pcre.get_substring subs 1) in let d = int_of_string (Pcre.get_substring subs 2) in Some (PVPart (Part (CCISS (c, d), Pcre.get_substring subs 3))) with Not_found -> try let subs = Pcre.exec ~rex:cciss name in let c = int_of_string (Pcre.get_substring subs 1) in let d = int_of_string (Pcre.get_substring subs 2) in Some (PVDev (CCISS (c, d))) with Not_found -> try let subs = Pcre.exec ~rex:lv name in let vg = Pcre.get_substring subs 1 in let lv = Pcre.get_substring subs 2 in Some (PVPart (LV (vg, lv))) with Not_found -> None 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 -> "" let architecture_of_string = function | str when String.length str = 4 && (str.[0] = 'i' || str.[0] = 'I') && (str.[1] >= '3' && str.[1] <= '6') && str.[2] = '8' && str.[3] = '6' -> I386 | "x86_64" | "X86_64" | "x86-64" | "X86-64" -> X86_64 | "ia64" | "IA64" -> IA64 | "ppc" | "PPC" | "ppc32" | "PPC32" -> PPC | "ppc64" | "PPC64" -> PPC64 | "sparc" | "SPARC" | "sparc32" | "SPARC32" -> SPARC | "sparc64" | "SPARC64" -> SPARC64 | "" -> UnknownArch | str -> OtherArch str type wordsize = | W32 | W64 | WUnknown let wordsize_of_architecture = function | I386 -> W32 | X86_64 -> W64 | IA64 -> W64 | PPC -> W32 | PPC64 -> W64 | SPARC -> W32 | SPARC64 -> W64 | OtherArch arch -> WUnknown | UnknownArch -> WUnknown 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 -> s_ "Linux swap" | LinuxRoot (architecture, distro) -> string_of_linux_distro distro ^ " " ^ string_of_architecture architecture | WindowsRoot -> s_ "Windows root" | LinuxBoot -> s_ "Linux /boot" | NotRoot -> s_ "Mountable non-root" | UnknownNature -> s_ "Unknown partition type" 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" (* XML helper functions. *) let rec children_with_name name xml = let children = Xml.children xml in List.filter ( function | Xml.Element (n, _, _) when n = name -> true | _ -> false ) children and xml_has_pcdata_child name pcdata xml = xml_has_child_matching ( function | Xml.Element (n, _, [Xml.PCData pcd]) when n = name && pcd = pcdata -> true | _ -> false ) xml and xml_has_attrib_child name attrib xml = xml_has_child_matching ( function | Xml.Element (n, attribs, _) when n = name && List.mem attrib attribs -> true | _ -> false ) xml and xml_has_child_matching f xml = let children = Xml.children xml in List.exists f children and find_child_with_name name xml = let children = children_with_name name xml in match children with | [] -> raise Not_found | h :: _ -> h and find_pcdata_child name xml = let children = children_with_name name xml in let rec loop = function | [] -> raise Not_found | Xml.Element (_, _, [Xml.PCData pcd]) :: _ -> pcd | _ :: tl -> loop tl in loop children type ('a, 'b) either = Either of 'a | Or of 'b (* We go into and out of newt mode at various stages, but we might * also need to put up a message at any time. This keeps track of * whether we are in newt mode or not. * * General tip: Try to do any complex operations like setting up the * network or probing disks outside newt mode, and try not to throw * exceptions in newt mode. *) let in_newt = ref false let with_newt f = if !in_newt then f () else ( in_newt := true; let r = try Either (Newt.init_and_finish f) with exn -> Or exn in in_newt := false; match r with Either r -> r | Or exn -> raise exn ) (* Clear the screen, open a new centered window, make sure the background * and help messages are consistent. *) let open_centered_window ?stage width height title = if not !in_newt then failwith (s_ "open_centered_window: not in newt mode"); Newt.cls (); Newt.centered_window width height title; let root_text = program_name ^ (match stage with | None -> "" | Some stage -> " - " ^ stage) in Newt.draw_root_text 0 0 root_text; Newt.push_help_line (s_ "F12 for next screen | [ALT] [F2] root / no password for shell") let ok_button = " OK " (* Some general dialog boxes. *) let message_box title text = with_newt ( fun () -> open_centered_window 40 20 title; let textbox = Newt.textbox 1 1 36 14 [Newt.WRAP; Newt.SCROLL] in Newt.textbox_set_text textbox text; let ok = Newt.button 28 16 ok_button in let form = Newt.form None None [] in Newt.form_add_components form [textbox; ok]; Newt.component_takes_focus ok true; ignore (Newt.run_form form); Newt.pop_window () ) (* Fail and exit with error. *) let failwith text = prerr_endline text; let text = "\n" ^ text ^ s_ "\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 message_box (s_ "Error") text; exit 1 (* Display a dialog with checkboxes, return the multiple selected items. *) let select_multiple ?stage ?(force_one = false) width title items = with_newt ( fun () -> open_centered_window ?stage width 20 title; let entries = List.mapi ( fun i (label, handle, selected) -> let cb = Newt.checkbox 1 (i+1) label (if selected then '*' else ' ') None in (handle, cb) ) items in let ok = Newt.button 48 16 ok_button in let vb = if List.length entries > 10 then Some (Newt.vertical_scrollbar 58 1 10 Newt_int.NEWT_COLORSET_WINDOW Newt_int.NEWT_COLORSET_ACTCHECKBOX) else None in let form = Newt.form vb None [] in Newt.form_add_components form (List.map snd entries); Newt.form_add_component form ok; let selected = let rec loop () = ignore (Newt.run_form form); let selected = List.filter_map ( fun (handle, cb) -> if Newt.checkbox_get_value cb = '*' then Some handle else None ) entries in if force_one && selected = [] then loop () else selected in loop () in Newt.pop_window (); selected ) (* Display a dialog with radio buttons, return the single selected item. *) let select_single ?stage width title items = if items = [] then failwith "select_single: no items"; with_newt ( fun () -> open_centered_window ?stage width 20 title; let prev = ref None in let entries = List.mapi ( fun i (label, handle) -> let rb = Newt.radio_button 1 (i+1) label (!prev = None) !prev in prev := Some rb; (handle, rb) ) items in let ok = Newt.button (width-12) 16 ok_button in let vb = if List.length entries > 10 then Some (Newt.vertical_scrollbar 58 1 10 Newt_int.NEWT_COLORSET_WINDOW Newt_int.NEWT_COLORSET_ACTCHECKBOX) else None in let form = Newt.form vb None [] in Newt.form_add_components form (List.map snd entries); Newt.form_add_component form ok; let (selected, _) = let rec loop () = ignore (Newt.run_form form); let r = Option.get !prev in let r = Newt.radio_get_current r in (* Now we compare 'r' to all the 'rb's in the list * to see which one is selected. *) try List.find (fun (_, rb) -> Newt.component_equals r rb) entries with Not_found -> loop () in loop () in Newt.pop_window (); selected ) (* 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 failwith (sprintf (f_ "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 (f_ "shget: command killed by signal %d") i) | WSTOPPED i -> failwith (sprintf (f_ "shget: command stopped by signal %d") i) (* Start an interactive shell. Need to juggle file descriptors a bit * because bash write PS1 to stderr (currently directed to the logfile). *) let shell () = 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 = 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 (*----------------------------------------------------------------------*) (* P2V-specific helper functions. *) (* 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 () (* Parse the output of 'lvs' to get list of LV names, sizes, * corresponding PVs, etc. * * Returns a list of LVs, and a list of PVs. *) let get_lvs () = match shget "lvs --noheadings -o vg_name,lv_name,devices" with | None -> [], [] | Some lines -> let all_pvs = ref [] in let lines = List.map Pcre.split lines in let lvs = List.map ( function | [vg; lv; pvs] | [_; vg; lv; pvs] -> let pvs = String.nsplit pvs "," in let pvs = List.filter_map pv_of_dev pvs in all_pvs := !all_pvs @ pvs; LV (vg, lv) | line -> failwith ("lvs: " ^ s_ "unexpected output: " ^ String.concat "," line) ) lines in lvs, sort_uniq !all_pvs (* Get all block devices attached to the system. Also queries and * returns the size in bytes of each. It tries to ignore any * removable block devices like CD-ROMs. *) let get_all_block_devices () = let sys_block_entries = List.sort (Array.to_list (Sys.readdir "/sys/block")) in let get name filter = let devices = List.filter_map filter sys_block_entries in eprintf "get_all_block_devices: %s: block devices: %s\n%!" name (String.concat "; " (List.map dev_of_block_device 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 " ^ (dev_of_block_device 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: %s: non-removable block devices: %s\n%!" name (String.concat "; " (List.map (fun (d, b) -> sprintf "%s [%Ld]" (dev_of_block_device d) b) devices)); devices in (* Search for hdX. *) let rex = Pcre.regexp "^hd([a-z]+)$" in let filter name = try let subs = Pcre.exec ~rex name in Some (HD (Pcre.get_substring subs 1)) with Not_found -> None in let devices = get "hd" filter in (* Search for sdX. *) let rex = Pcre.regexp "^sd([a-z]+)$" in let filter name = try let subs = Pcre.exec ~rex name in Some (SD (Pcre.get_substring subs 1)) with Not_found -> None in let devices = devices @ get "sd" filter in (* Search for cciss. *) let rex = Pcre.regexp "^cciss!c(\\d+)d(\\d+)$" in let filter name = try let subs = Pcre.exec ~rex name in let c = int_of_string (Pcre.get_substring subs 1) in let d = int_of_string (Pcre.get_substring subs 2) in Some (CCISS (c, d)) with Not_found -> None in let devices = devices @ get "cciss" filter in devices (* Get the partitions on a block device. * eg. SD "a" -> [Part (SD "a","1"); Part (SD "a", "2")] *) let get_partitions dev = (* Read the device directory, eg. /sys/block/hda, which we expect * to contain partition devices like /sys/block/hda/hda1 etc. *) let subdir, rex = match dev with | HD n -> "hd" ^ n, sprintf "^hd%s(.+)$" n | SD n -> "sd" ^ n, sprintf "^sd%s(.+)$" n | CCISS (c,d) -> sprintf "cciss!c%dd%d" c d, sprintf "^cciss!c%dd%d(p.+)$" c d in let rex = Pcre.regexp rex in let dir = "/sys/block/" ^ subdir in let parts = Sys.readdir dir in let parts = Array.to_list parts in let parts = List.filter ( fun name -> is_dir (dir ^ "/" ^ name) = Some true ) 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 (short_dev_of_block_device 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 origin_dev = dev_of_block_device origin_dev in let sectors = let cmd = "blockdev --getsz " ^ (quote origin_dev) in let lines = shget cmd in match lines with | Some (sectors::_) -> Int64.of_string sectors | Some [] | None -> failwith (sprintf (f_ "Disk 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 %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 () = (* Fedora gives an error if this file doesn't exist. *) sh "touch /etc/resolv.conf"; (* NB. Lazy unmount is required because dhclient keeps its current * directory open on /etc/sysconfig/network-scripts/ * (Fixed in dhcp >= 4.0.0 but be generous anyway). *) sh "mount -o bind /mnt/root/etc /etc"; let status = shwithstatus "/etc/init.d/network start" in sh "umount -l /etc"; (* Try to ping the default gateway to see if this worked. *) shfailok "ping -c3 `/sbin/ip route list match 0.0.0.0 | head -1 | awk '{print $3}'`"; if !config_greeting then ( print_endline (s_ "\n\nDid automatic network configuration work?\nHint: If not sure, there is a shell on console [ALT] [F2]"); 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 (* Configure the network statically. *) let static_network (interface, address, netmask, gateway, nameserver) = let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in try do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s" (quote interface) (quote address) (quote netmask)); do_cmd_or_exit (sprintf "route add default gw %s %s" (quote gateway) (quote interface)); if nameserver <> "" then do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf" (quote nameserver)); true (* succeeded *) with Exit -> false (* failed *) (* http://fabrice.bellard.free.fr/qemu/qemu-doc.html#SEC30 *) let qemu_network () = sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0"; sh "route add default gw 10.0.2.2 eth0"; sh "echo nameserver 10.0.2.3 > /etc/resolv.conf" (* Make an SSH connection to the remote machine, execute command. * The connection remains open until you call ssh_disconnect, it * times out or there is some error. * * NB. The command is NOT quoted. * * Returns a pair (file descriptor, channel), both referring to the * same thing. Use whichever is more convenient. *) let ssh_connect config cmd = let cmd = sprintf "ssh%s -l %s -p %s %s %s" (if config.ssh_compression then " -C" else "") (quote config.ssh_username) (quote config.ssh_port) (quote config.ssh_host) cmd in eprintf "ssh_connect: %s\n%!" cmd; let chan = open_process_out cmd in descr_of_out_channel chan, chan let ssh_disconnect (_, chan) = eprintf "ssh_disconnect\n%!"; match close_process_out chan with | WEXITED 0 -> () (* OK *) | WEXITED i -> failwith (sprintf (f_ "ssh: exited with error code %d") i) | WSIGNALED i -> failwith (sprintf (f_ "ssh: killed by signal %d") i) | WSTOPPED i -> failwith (sprintf (f_ "ssh: stopped by signal %d") i) (* Use these functions to upload a file. *) let ssh_start_upload config filename = let cmd = sprintf "cat \\> %s/%s" (quote config.ssh_directory) (quote filename) in ssh_connect config cmd let ssh_finish_upload = ssh_disconnect (* Test SSH connection. *) let test_ssh config = print_endline (s_ "Testing SSH connection by listing files in remote directory ...\n"); let cmd = sprintf "/bin/ls %s" (quote config.ssh_directory) in let conn = ssh_connect config cmd in ssh_disconnect conn; if !config_greeting then ( print_endline (s_ "\n\nDid SSH work?\nHint: 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 true (* Rewrite /mnt/root/etc/fstab. *) let rewrite_fstab remote_map = 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 lines in let lines = List.map ( function | dev :: rest when String.starts_with dev "/dev/" -> let remote_dev = match pv_of_dev dev with (* eg. /dev/sda1 where sda is in the map *) | Some (PVPart (Part (pdev, partnum))) -> (try List.assoc pdev remote_map ^ partnum with Not_found -> dev ); | Some (PVDev pdev) -> (* eg. /dev/sda *) (try List.assoc pdev remote_map with Not_found -> dev ); | _ -> dev in remote_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); output_char chan '\n' ) lines; close_out chan ) (* Generate a random MAC address in the Xen-reserved space. *) let random_mac_address () = let random = List.map (sprintf "%02x") ( List.map (fun _ -> Random.int 256) [0;0;0] ) in String.concat ":" ("00"::"16"::"3e"::random) (* Generate a random UUID. *) let random_uuid = let hex = "0123456789abcdef" in fun () -> let str = String.create 32 in for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done; str (*----------------------------------------------------------------------*) (* Main entry point. *) (* The general plan for the main function is to operate in stages: * * Start-up * | * V * Information gathering about the system * | (eg. block devices, number of CPUs, etc.) * V * Greeting and type of transfer question * | * V * Set up the network * | (after this point we have a working network) * V * Set up SSH * | (after this point we have a working SSH connection) * V * Questions about what to transfer (block devs, root fs) <--. * | | * V | * Questions about hypervisor configuration | * | | * V | * Verify information -------- user wants to change info ----/ * | * V * Perform transfer * * Prior versions of virt-p2v (the ones which used 'dialog') had support * for a back button so they could go back through dialogs. I removed * this because it was hard to support and not particularly useful. *) let rec main ttyname = Random.self_init (); (* Running from an init script. We don't have much of a * login environment, so set one up. *) putenv "PATH" (String.concat ":" ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin"; "/usr/bin"; "/bin"]); putenv "HOME" "/root"; putenv "LOGNAME" "root"; (* We can safely write in /tmp (it's a synthetic live CD directory). *) chdir "/tmp"; (* Set up logging to /tmp/virt-p2v.log. *) let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in dup2 fd stderr; close fd; (* Log the start up time. *) eprintf "\n\n**************************************************\n\n"; let tm = localtime (time ()) in eprintf "%s starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!" program_name (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. *) (match ttyname with | None -> () | Some ttyname -> let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in dup2 fd stdin; dup2 fd stdout; close fd ); (* Choose language early, so messages are translated. *) if !config_greeting && List.length supported_langs > 1 then ( with_newt ( fun () -> let lang = select_single ~stage:(s_ "Select language") 40 (s_ "Select language") supported_langs in putenv "LANG" lang; ignore (GettextStubCompat.setlocale GettextStubCompat.LC_ALL lang) ) ); let () = printf (f_ "%s starting up ...\n%!") program_name in (* Disable screen blanking on tty. *) sh "setterm -blank 0"; (* Check that the environment is a sane-looking live CD. If not, bail. *) if not test_dialog_stages && is_dir "/mnt/root" <> Some true then failwith (s_ "You should only run this script from the live CD or a USB key."); (* Start of the information gathering phase. *) print_endline (s_ "Detecting hard drives (this may take some time) ..."); (* Search for all non-removable block devices. Do this early and bail * if we can't find anything. * * This is a list of block_device, like HD "a", and size in bytes. *) let all_block_devices : (block_device * int64) list = let devices = get_all_block_devices () in if devices = [] then failwith (s_ "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 = get_lvs () in eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " (List.map string_of_pv pvs)); eprintf "all_partitions: LVs: %s\n%!" (String.concat "; " (List.map dev_of_partition lvs)); (* For now just ignore any block devices which are PVs. *) let block_devices = List.filter ( fun (dev, _) -> not (List.mem (PVDev dev) pvs) ) all_block_devices in (* Partitions (eg. "sda1", "sda2"). *) let parts = let parts = List.map fst 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 _) as p -> not (List.mem (PVPart p) 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 (* Run blockdev --getsize64 on each partition to get its size. * * Returns a list of partitions and their size in bytes. *) let all_partitions : (partition * int64) list = List.filter_map ( fun part -> let cmd = "blockdev --getsize64 " ^ quote (dev_of_partition part) in let lines = shget cmd in match lines with | Some (blksize::_) -> Some (part, Int64.of_string blksize) | Some [] | None -> None ) all_partitions in (* Try to determine the nature of each partition. * Root? Swap? Architecture? etc. *) let all_partitions : (partition * (int64 * 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, size) -> 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, (size, nature)) ) all_partitions in print_endline (s_ "Finished detecting hard drives."); (* Autodetect system memory. *) let system_memory = (* Try to parse dmesg first to find the 'Memory:' report when * the kernel booted. If available, this can give us an * indication of usable RAM on this system. *) let dmesg = shget "dmesg" in try let dmesg = match dmesg with Some lines -> lines | None -> raise Not_found in let line = List.find (fun line -> String.starts_with line "Memory: ") dmesg in let subs = Pcre.exec ~pat:"k/([[:digit:]]+)k available" line in let mem = Pcre.get_substring subs 1 in int_of_string mem / 1024 with Not_found | Failure "int_of_string" -> (* 'dmesg' can't be parsed. The backup plan is to look * at /proc/meminfo. *) let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in match mem with | Some (mem::_) -> int_of_float (float_of_string mem) (* For some reason even /proc/meminfo didn't work. Just * assume 256 MB instead. *) | _ -> 256 in (* Autodetect system # pCPUs. *) let system_nr_cpus = let cpus = shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in match cpus with | Some (cpus::_) -> int_of_string cpus | _ -> 1 in (* Greeting, type of transfer, network question stages. * These are all done in newt mode. *) let config_transfer_type, config_network = with_newt ( fun () -> (* Greeting. *) if !config_greeting then message_box program_name (sprintf (f_ "Welcome to %s, 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.") program_name); (* Type of transfer. *) let config_transfer_type = match !config_transfer_type with | Some t -> t | None -> let items = [ s_ "Physical to Virtual (P2V)", P2V; s_ "Virtual to Virtual (V2V)", V2V; ] in select_single ~stage:(s_ "Transfer type") 40 (s_ "Transfer type") items in (* Network configuration. *) let config_network = match !config_network with | Some n -> n | None -> open_centered_window ~stage:(s_ "Network") 60 20 (s_ "Configure network"); let autolist = Newt.listbox 4 2 4 [Newt.SCROLL] in Newt.listbox_set_width autolist 52; (* Populate the "Automatic" listbox with RHEL/Fedora * root partitions found which allow us to do * automatic configuration in a known way. *) let rec loop = function | [] -> () | (partition, (_, LinuxRoot (_, ((RHEL _|Fedora _) as distro)))) :: parts -> let label = sprintf "%s (%s)" (dev_of_partition partition) (string_of_linux_distro distro) in ignore (Newt.listbox_append_entry autolist label partition); loop parts | _ :: parts -> loop parts in loop all_partitions; (* If there is no suitable root partition (the listbox * is empty) then disable the auto option and the listbox. *) let no_auto = Newt.listbox_item_count autolist = 0 in let auto = Newt.radio_button 1 1 (s_ "Automatic from:") (not no_auto) None in let shell = Newt.radio_button 1 6 (s_ "Start a shell") no_auto (Some auto) in if no_auto then ( Newt.component_takes_focus auto false; Newt.component_takes_focus (Newt.component_of_listbox autolist) false ); let qemu = Newt.radio_button 1 7 (s_ "QEMU user network") false (Some shell) in let nonet = Newt.radio_button 1 8 (s_ "Don't configure the network") false (Some qemu) in let static = Newt.radio_button 1 9 (s_ "Static configuration:") false (Some nonet) in let label1 = Newt.label 4 10 (s_ "Interface") in let entry1 = Newt.entry 16 10 (Some "eth0") 8 [] in let label2 = Newt.label 4 11 (s_ "IP") in let entry2 = Newt.entry 16 11 None 16 [] in let label3 = Newt.label 4 12 (s_ "Netmask") in let entry3 = Newt.entry 16 12 (Some "255.255.255.0") 16 [] in let label4 = Newt.label 4 13 (s_ "Gateway") in let entry4 = Newt.entry 16 13 None 16 [] in let label5 = Newt.label 4 14 (s_ "Nameserver") in let entry5 = Newt.entry 16 14 None 16 [] in let enable_static () = Newt.component_takes_focus entry1 true; Newt.component_takes_focus entry2 true; Newt.component_takes_focus entry3 true; Newt.component_takes_focus entry4 true; Newt.component_takes_focus entry5 true in let disable_static () = Newt.component_takes_focus entry1 false; Newt.component_takes_focus entry2 false; Newt.component_takes_focus entry3 false; Newt.component_takes_focus entry4 false; Newt.component_takes_focus entry5 false in let enable_autolist () = Newt.component_takes_focus (Newt.component_of_listbox autolist) true in let disable_autolist () = Newt.component_takes_focus (Newt.component_of_listbox autolist) false in disable_static (); Newt.component_add_callback auto (fun () ->disable_static (); enable_autolist ()); Newt.component_add_callback shell (fun () -> disable_static (); disable_autolist ()); Newt.component_add_callback qemu (fun () -> disable_static (); disable_autolist ()); Newt.component_add_callback nonet (fun () -> disable_static (); disable_autolist ()); Newt.component_add_callback static (fun () -> enable_static (); disable_autolist ()); let ok = Newt.button 48 16 ok_button in let form = Newt.form None None [] in Newt.form_add_components form [auto; Newt.component_of_listbox autolist; shell;qemu;nonet;static; label1;label2;label3;label4;label5; entry1;entry2;entry3;entry4;entry5; ok]; let n = let rec loop () = ignore (Newt.run_form form); let r = Newt.radio_get_current auto in if Newt.component_equals r auto then ( match Newt.listbox_get_current autolist with | None -> loop () | Some part -> Auto part ) else if Newt.component_equals r shell then Shell else if Newt.component_equals r qemu then QEMUUserNet else if Newt.component_equals r nonet then NoNetwork else if Newt.component_equals r static then ( let interface = Newt.entry_get_value entry1 in let address = Newt.entry_get_value entry2 in let netmask = Newt.entry_get_value entry3 in let gateway = Newt.entry_get_value entry4 in let nameserver = Newt.entry_get_value entry5 in if interface = "" || address = "" || netmask = "" || gateway = "" then loop () else Static (interface, address, netmask, gateway, nameserver) ) else loop () in loop () in Newt.pop_window (); n in config_transfer_type, config_network ) in (* Try to bring up the network. *) (match config_network with | Shell -> print_endline (s_ "Network configuration.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n"); shell () | Static (interface, address, netmask, gateway, nameserver) -> print_endline (s_ "Trying static network configuration.\n"); if not (static_network (interface, address, netmask, gateway, nameserver)) then ( print_endline (s_ "\nAuto-configuration failed. Starting a shell.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n"); shell () ) | Auto rootfs -> print_endline (s_ "Trying network auto-configuration from root filesystem ...\n"); (* Mount the root filesystem read-only under /mnt/root. *) sh ("mount -o ro " ^ quote (dev_of_partition rootfs) ^ " /mnt/root"); if not (auto_network ()) then ( print_endline (s_ "\nAuto-configuration failed. Starting a shell.\n\nPlease configure the network from this shell.\n\nWhen you have finished, exit the shell with ^D or exit.\n"); shell () ); (* NB. Lazy unmount is required because dhclient keeps its current * directory open on /etc/sysconfig/network-scripts/ *) sh ("umount -l /mnt/root"); | QEMUUserNet -> print_endline (s_ "Trying QEMU network configuration.\n"); qemu_network () | NoNetwork -> (* this is easy ... *) () ); (* SSH configuration phase. *) let config_ssh = with_newt ( fun () -> match !config_ssh with | Some c -> c | None -> (* Query the user for SSH configuration. *) open_centered_window ~stage:(s_ "SSH configuration") 60 20 (s_ "SSH configuration"); let label1 = Newt.label 1 1 (s_ "Remote host") in let host = Newt.entry 20 1 None 36 [] in let label2 = Newt.label 1 2 (s_ "Remote port") in let port = Newt.entry 20 2 (Some "22") 6 [] in let label3 = Newt.label 1 3 (s_ "Remote directory") in let dir = Newt.entry 20 3 (Some "/var/lib/xen/images") 36 [] in let label4 = Newt.label 1 4 (s_ "SSH username") in let user = Newt.entry 20 4 (Some "root") 16 [] in (* There's no sensible way to support this for SSH: let label5 = Newt.label 1 5 (s_ "SSH password") in let pass = Newt.entry 20 5 None 16 [Newt.PASSWORD] in *) let compr = Newt.checkbox 16 7 (s_ "Use SSH compression (not good for LANs)") ' ' None in let check = Newt.checkbox 16 9 (s_ "Test SSH connection") '*' None in let ok = Newt.button 48 16 ok_button in let form = Newt.form None None [] in Newt.form_add_components form [label1;label2;label3;label4; host;port;dir;user; compr;check; ok]; let c = let rec loop () = ignore (Newt.run_form form); let host = Newt.entry_get_value host in let port = Newt.entry_get_value port in let dir = Newt.entry_get_value dir in let user = Newt.entry_get_value user in let compr = Newt.checkbox_get_value compr = '*' in let check = Newt.checkbox_get_value check = '*' in if host <> "" && port <> "" && user <> "" then { ssh_host = host; ssh_port = port; ssh_directory = dir; ssh_username = user; ssh_compression = compr; ssh_check = check; } else loop () in loop () in Newt.pop_window (); c ) in (* If asked, check the SSH connection. *) if config_ssh.ssh_check then if not (test_ssh config_ssh) then failwith (s_ "SSH configuration failed"); (* Devices and root partition and target configuration selection stage. *) let config_devices_to_send, config_root_filesystem, config_target = with_newt ( fun () -> let config_devices_to_send = match !config_devices_to_send with | Some ds -> ds | None -> let items = List.map ( fun (dev, size) -> let label = sprintf "%s (%.3f GB)" (dev_of_block_device dev) ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in (label, dev, true) ) all_block_devices in select_multiple ~stage:(s_ "Block devices") ~force_one:true 60 (s_ "Select block devices to send") items in let config_root_filesystem = match !config_root_filesystem with | Some fs -> fs | None -> let items = List.map ( fun (part, (_, nature)) -> let label = sprintf "%s %s" (dev_of_partition part) (string_of_nature nature) in (label, part) ) all_partitions in select_single ~stage:(s_ "Root filesystem") 60 (s_ "Select root filesystem") items in let config_target = match !config_target with | Some t -> t | None -> open_centered_window ~stage:(s_ "Target system") 40 20 (s_ "Configure target system"); let hvlabel = Newt.label 1 1 (s_ "Hypervisor:") in let hvlistbox = Newt.listbox 16 1 4 [Newt.SCROLL] in Newt.listbox_append_entry hvlistbox "Xen" (Some Xen); Newt.listbox_append_entry hvlistbox "QEMU" (Some QEMU); Newt.listbox_append_entry hvlistbox "KVM" (Some KVM); Newt.listbox_append_entry hvlistbox "Other" None; let archlabel = Newt.label 1 5 (s_ "Architecture:") in let archlistbox = Newt.listbox 16 5 4 [Newt.SCROLL] in Newt.listbox_append_entry archlistbox "i386" I386; Newt.listbox_append_entry archlistbox "x86-64 (64-bit x86)" X86_64; Newt.listbox_append_entry archlistbox "IA64 (Itanium)" IA64; Newt.listbox_append_entry archlistbox "PowerPC 32-bit" PPC; Newt.listbox_append_entry archlistbox "PowerPC 64-bit" PPC64; Newt.listbox_append_entry archlistbox "SPARC 32-bit" SPARC; Newt.listbox_append_entry archlistbox "SPARC 64-bit" SPARC64; Newt.listbox_append_entry archlistbox "Unknown/other" UnknownArch; (* Get the architecture of the selected root filesystem. * If not known, default to UnknownArch. *) Newt.listbox_set_current_by_key archlistbox UnknownArch; (try match List.assoc config_root_filesystem all_partitions with | _, LinuxRoot (arch, _) -> Newt.listbox_set_current_by_key archlistbox arch | _ -> () with Not_found -> ()); let memlabel = Newt.label 1 9 (s_ "Memory (MB):") in let mementry = Newt.entry 16 9 (Some (string_of_int system_memory)) 8 [] in let cpulabel = Newt.label 1 10 (s_ "CPUs:") in let cpuentry = Newt.entry 16 10 (Some (string_of_int system_nr_cpus)) 4 [] in let maclabel = Newt.label 1 11 (s_ "MAC addr:") in let macentry = Newt.entry 16 11 None 20 [] in let maclabel2 = Newt.label 1 12 (s_ "(leave MAC blank for random)") in let libvirtd = Newt.checkbox 12 14 (s_ "Use remote libvirtd") '*' None in let ok = Newt.button 28 16 ok_button in let form = Newt.form None None [] in Newt.form_add_components form [hvlabel; Newt.component_of_listbox hvlistbox; archlabel; Newt.component_of_listbox archlistbox; memlabel; mementry; cpulabel; cpuentry; maclabel; macentry; maclabel2; libvirtd; ok]; let c = let rec loop () = ignore (Newt.run_form form); try let hv = Newt.listbox_get_current hvlistbox in let arch = Newt.listbox_get_current archlistbox in let mem = int_of_string (Newt.entry_get_value mementry) in let cpus = int_of_string (Newt.entry_get_value cpuentry) in let mac = Newt.entry_get_value macentry in let libvirtd = Newt.checkbox_get_value libvirtd = '*' in if hv <> None && arch <> None && mem >= 0 && cpus >= 0 then { tgt_hypervisor = Option.get hv; tgt_architecture = Option.get arch; tgt_memory = mem; tgt_vcpus = cpus; tgt_mac_address = if mac <> "" then mac else random_mac_address (); tgt_libvirtd = libvirtd } else loop () with Not_found | Failure "int_of_string" -> loop () in loop () in Newt.pop_window (); c in config_devices_to_send, config_root_filesystem, config_target ) in (* If architecture is set to UnknownArch, then assume the same * architecture as the live CD. *) let config_target = match config_target.tgt_architecture with | UnknownArch -> let arch = shget "uname -m" in let arch = match arch with | Some (arch :: _) -> architecture_of_string arch | _ -> I386 (* probably wrong XXX *) in { config_target with tgt_architecture = arch } | _ -> config_target in (* Try to get the capabilities from the remote machine. If we fail * it doesn't matter too much. *) let caps_os_type, caps_emulator, caps_loader, caps_machine = try if not config_target.tgt_libvirtd then raise Not_found; let proto, path = match config_target.tgt_hypervisor with | Some Xen -> "xen", "/" | Some (QEMU|KVM) -> "qemu", "/system" | None -> raise Not_found in let name = sprintf "%s+ssh://%s@%s:%s%s" proto config_ssh.ssh_username config_ssh.ssh_host config_ssh.ssh_port path in eprintf "capabilities URI = %S\n%!" name; print_endline (s_ "Try to fetch remote hypervisor capabilities ...\n"); let conn = Libvirt.Connect.connect_readonly ~name () in let caps = Libvirt.Connect.get_capabilities conn in Libvirt.Connect.close conn; (* Turn it into XML data. *) let caps = Xml.parse_string caps in eprintf "capabilities:\n%s\n%!" (Xml.to_string_fmt caps); (* We're looking for a guest with hvm * and ... Later when we can * install PV drivers automatically, we will want to look * for paravirt guest types too. *) let guests = children_with_name "guest" caps in let guests = List.filter (xml_has_pcdata_child "os_type" "hvm") guests in let arch_str = string_of_architecture config_target.tgt_architecture in let guests = List.filter ( xml_has_child_matching ( function | Xml.Element (n, attribs, _) when n = "arch" && List.exists ( fun (n, a) -> n = "name" && (* deal with i386 vs i686 pestilence *) architecture_of_string a = config_target.tgt_architecture ) attribs -> true | _ -> false ) ) guests in (* In theory at this point we only have a single guest type * remaining. It might be that we have _zero_ available * guest types, which indicates probably an unsupported * capability of the remote hypervisor (or just that one of * many parsing or heuristics failed). It might be that * we have > 1 available guest types, which indicates some * feature we don't know about. *) let len = List.length guests in if len = 0 then ( message_box (s_ "Warning") (sprintf (f_ "Remote hypervisor claims not to support fully virtualized %s guests.\n\nContinuing anyway.\n\n%!") arch_str); raise Not_found ); if len > 1 then ( message_box (s_ "Note") (sprintf (f_ "Remote hypervisor supports multiple types of fully virtualized %s guests.\n\nPlease help further development of libvirt and virt-p2v by sending the file /tmp/virt-p2v.log back to the developers. See the main virt-p2v website for contact details.") arch_str) ); let guest = List.hd guests in let os_type = try Some (find_pcdata_child "os_type" guest) with Not_found -> None in let arch_section = find_child_with_name "arch" guest in let emulator = try Some (find_pcdata_child "emulator" arch_section) with Not_found -> None in let loader = try Some (find_pcdata_child "loader" arch_section) with Not_found -> None in let machine = try Some (find_pcdata_child "machine" arch_section) with Not_found -> None in os_type, emulator, loader, machine with | Not_found -> None, None, None, None | Xml.Error err -> eprintf "XML error: %s\n%!" (Xml.error err); None, None, None, None | Xml.Not_element _ | Xml.Not_pcdata _ | Xml.No_attribute _ -> (* If these occur, need to add some more debugging. *) eprintf "XML error when parsing capabilities\n%!"; None, None, None, None | Libvirt.Virterror err -> eprintf "libvirt error: %s\n%!" (Libvirt.Virterror.to_string err); None, None, None, None | Invalid_argument str -> eprintf "libvirt error: %s\n%!" str; None, None, None, None in (* In test mode, exit here before we do Bad Things to the developer's * hard disk. *) if test_dialog_stages then exit 1; print_endline (s_ "Performing LVM snapshots ...\n"); (* 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 config_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) ) config_devices_to_send in (* Run kpartx on the snapshots. *) List.iter ( fun (origin, snapshot) -> shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot)) ) config_devices_to_send; (* Rescan for LVs. *) sh "vgscan"; sh "vgchange -a y"; (* Mount the root filesystem under /mnt/root. *) (match config_root_filesystem with | Part (dev, p) -> let snapshot_dev = snapshot_name dev in sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev ^ p) ^ " /mnt/root") | (LV _) as lv -> (* The LV will be backed by a snapshot device, so just mount * directly. *) let dev = dev_of_partition lv in sh ("mount " ^ quote dev ^ " /mnt/root") ); (* Work out what devices will be called at the remote end and make * a map of original device to remapped device name. This is * quite simple for now: just map the devices to "hda", "hdb", * etc. (assuming full virt target for now). *) let remote_map = (* To generate "a", "b", ..., "aa", "ab", etc. The 'digits' are * stored in reverse. *) let num = ref ['a'] in let rec next_num_of num = match num with | [] -> assert false | 'z' :: [] -> [ 'a'; 'a' ] | 'z' :: nums -> 'a' :: next_num_of nums | c :: nums -> Char.chr (Char.code c + 1) :: nums in let get_hdX num = "hd" ^ String.implode (List.rev num) in List.map ( fun (origin_dev, _) -> let remote_dev = get_hdX !num in num := next_num_of !num; (origin_dev, remote_dev) ) config_devices_to_send in (* Modify files on the root filesystem. *) rewrite_fstab remote_map; (* XXX Other files to rewrite? *) (* Unmount the root filesystem and sync disks. *) sh "umount /mnt/root"; sh "sync"; (* Ugh, should be in stdlib. *) (* 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 config_devices_to_send = List.map ( fun (origin_dev, snapshot_dev) -> let remote_dev = List.assoc origin_dev remote_map in let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in (origin_dev, snapshot_dev, remote_dev, remote_name) ) config_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 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 xml = (* Shortcut to make "value". *) 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 let arch_str = string_of_architecture config_target.tgt_architecture in let arch_wordsize = wordsize_of_architecture config_target.tgt_architecture in (* Standard stuff for every domain. *) let name = leaf "name" hostname in let uuid = leaf "uuid" (random_uuid ()) in let maxmem, memory = let m = string_of_int (config_target.tgt_memory * 1024) in leaf "maxmem" m, leaf "memory" m in let vcpu = leaf "vcpu" (string_of_int config_target.tgt_vcpus) in (* Top-level stuff which differs for each HV type (isn't this supposed * to be portable ...) *) let extras = (* Use capabilities for os_type, etc. else use some good guesses. *) let os_type = Option.default "hvm" caps_os_type in let machine = Option.default "pc" caps_machine in let loader = Option.default "/usr/lib/xen/boot/hvmloader" caps_loader in match config_target.tgt_hypervisor with | Some Xen -> [Xml.Element ("os", [], [leaf "type" os_type; leaf "loader" loader; tleaf "boot" ["dev", "hd"]]); Xml.Element ("features", [], [tleaf "pae" []; tleaf "acpi" []; tleaf "apic" []]); tleaf "clock" ["sync", "localtime"]] | Some KVM -> [Xml.Element ("os", [], [leaf "type" os_type]); tleaf "clock" ["sync", "localtime"]] | Some QEMU -> [Xml.Element ("os", [], [Xml.Element ("type", ["arch", arch_str; "machine", machine], [Xml.PCData os_type]); tleaf "boot" ["dev", "hd"]])] | None -> [] in (* section. *) let devices = let emulator = match caps_emulator with (* Use the emulator from the libvirt capabilities. *) | Some s -> [leaf "emulator" s] | None -> (* If we don't have libvirt capabilities, best guess. *) match config_target.tgt_hypervisor with | Some Xen -> [leaf "emulator" (if arch_wordsize = W64 then "/usr/lib64/xen/bin/qemu-dm" else "/usr/lib/xen/bin/qemu-dm")] | 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", config_target.tgt_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", config_ssh.ssh_directory ^ "/" ^ remote_name]; tleaf "target" ["dev", remote_dev]] ) ) config_devices_to_send in Xml.Element ( "devices", [], emulator @ interface :: graphics :: disks ) in (* Put it all together in . *) Xml.Element ( "domain", (match config_target.tgt_hypervisor with | Some Xen -> ["type", "xen"] | Some QEMU -> ["type", "qemu"] | Some KVM -> ["type", "kvm"] | None -> []), name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices] ) in (* Convert XML configuration file to a string, then send it to the * remote server. *) let () = let xml = Xml.to_string_fmt xml in let conn_arg = match config_target.tgt_hypervisor with | Some Xen | None -> "" | Some QEMU | Some KVM -> " -c qemu:///system" in let xml = sprintf (f_ "\ \n\n") program_name conn_arg conf_filename conn_arg hostname ^ xml ^ "\n" in let xml_len = String.length xml in eprintf "length of configuration file is %d bytes\n%!" xml_len; print_endline (s_ "\nWriting configuration file ...\n"); let (sock,_) as conn = ssh_start_upload config_ssh conf_filename in (* In OCaml this actually loops calling write(2) *) ignore (write sock xml 0 xml_len); ssh_finish_upload conn in (* 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%!" (dev_of_block_device origin_dev) remote_name; let size = try List.assoc origin_dev all_block_devices with Not_found -> assert false (* internal error *) in let () = printf (f_ "\nSending %s (%.3f GB) to remote machine\n\n%!") (dev_of_block_device origin_dev) ((Int64.to_float size) /. (1024.*.1024.*.1024.)) in (* Open the snapshot device. *) let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in (* Now connect. *) let (sock,_) as conn = ssh_start_upload config_ssh remote_name in (* Copy the data. *) let spinners = "|/-\\" (* "Oo" *) in let bufsize = 1024 * 1024 in let buffer = String.create bufsize in let start = gettimeofday () in let rec copy bytes_sent last_printed_at spinner = let n = read fd buffer 0 bufsize in if n > 0 then ( let n' = write sock buffer 0 n in if n <> n' then assert false; (* never, according to the manual *) let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in let last_printed_at, spinner = let now = gettimeofday () in (* Print progress every few seconds. *) if now -. last_printed_at > 2. then ( let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in let secs_elapsed = now -. start in printf "%.0f%% %c %.1f Mbps" (100. *. elapsed) spinners.[spinner] (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.); (* 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 (f_ " (about %.0f minutes remaining)") (secs_remaining/.60.) else printf (f_ " (about %.0f seconds remaining)") secs_remaining ); printf " \r%!"; let spinner = (spinner + 1) mod String.length spinners in now, spinner ) else last_printed_at, spinner in copy bytes_sent last_printed_at spinner ) in copy 0L start 0; printf "\n\n%!"; (* because of the messages printed above *) (* Disconnect. *) ssh_finish_upload conn ) config_devices_to_send; (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*) (* Clean up and reboot. *) ignore ( message_box (sprintf (f_ "%s has finished") program_name) (sprintf (f_ "\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.") config_ssh.ssh_directory conf_filename) ); shfailok "eject"; shfailok "reboot"; exit 0 (*----------------------------------------------------------------------*) let usage () = let () = eprintf (f_ "usage: virt-p2v [--test] [ttyname]\n%!") in 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 --test' just to check it compiles. When it is running * from the actual live CD, there is a single parameter which is the * tty name (so usually 'virt-p2v tty1'). *) let () = match Array.to_list Sys.argv with | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage (); | [ _; "--test" ] -> () (* Makefile test - do nothing. *) | [ _; 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 *)