X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=virt-p2v;h=b257bc4b074aea2b5179d17bcccccb08dc264380;hb=9f19b3137c4cd923a969d25d0abeb7603efb2e73;hp=36b186c2f179080c32aebd8327d7385c93199b64;hpb=24a1108a2457f823030f7991fc7578ad62b188e3;p=virt-p2v.git diff --git a/virt-p2v b/virt-p2v index 36b186c..b257bc4 100755 --- a/virt-p2v +++ b/virt-p2v @@ -37,12 +37,11 @@ type network = | NoNetwork type ssh_config = { ssh_host : string; (* Remote host for SSH. *) - ssh_port : int; (* Remote port. *) + ssh_port : string; (* Remote port. *) ssh_directory : string; (* Remote directory. *) ssh_username : string; (* Remote username. *) - ssh_password : string; (* Remote password/passphrase. *) + ssh_compression : bool; (* If true, use SSH compression. *) ssh_check : bool; (* If true, check SSH is working. *) - ssh_libvirtd : bool; (* If true, contact remote libvirtd. *) } type hypervisor = | Xen @@ -52,6 +51,16 @@ type architecture = | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64 | OtherArch of string | UnknownArch +type wordsize = + | W32 | W64 | WUnknown +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. @@ -88,33 +97,26 @@ let config_devices_to_send = ref None let config_root_filesystem = ref None (* Configuration of the target. *) -let config_hypervisor = ref None -let config_architecture = ref None -let config_memory = ref None -let config_vcpus = ref None -let config_mac_address = ref None -let config_compression = ref None +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 = true +let test_dialog_stages = false (* END OF CUSTOM virt-p2v SCRIPT SECTION. *) (*----------------------------------------------------------------------*) (* Load external libraries. *) ;; -#load "unix.cma";; -#directory "+extlib";; -#load "extLib.cma";; -#directory "+pcre";; -#load "pcre.cma";; -#directory "+newt";; -#load "mlnewt.cma";; -#directory "+xml-light";; -#load "xml-light.cma";; +#use "topfind";; +#require "extlib";; +#require "pcre";; +#require "newt";; +#require "xml-light";; +#require "gettext-stub";; +#require "libvirt";; open Unix open Printf @@ -122,6 +124,41 @@ 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 *) @@ -155,6 +192,32 @@ let string_of_architecture = function | 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 + +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: *) @@ -167,19 +230,58 @@ and linux_distro = RHEL of int * int | OtherLinux let rec string_of_nature = function - | LinuxSwap -> "Linux swap" + | LinuxSwap -> s_ "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" + | 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 @@ -206,7 +308,7 @@ let with_newt f = * and help messages are consistent. *) let open_centered_window ?stage width height title = - if not !in_newt then failwith "open_centered_window: not in newt mode"; + 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 = @@ -214,7 +316,10 @@ let open_centered_window ?stage width height title = | None -> "" | Some stage -> " - " ^ stage) in Newt.draw_root_text 0 0 root_text; - Newt.push_help_line "F12 for next screen | [ALT] [F2] root / no password for shell" + 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 = @@ -224,10 +329,9 @@ let message_box title text = 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 " in + let ok = Newt.button 28 16 ok_button in let form = Newt.form None None [] in - Newt.form_add_component form textbox; - Newt.form_add_component form ok; + Newt.form_add_components form [textbox; ok]; Newt.component_takes_focus ok true; @@ -238,17 +342,115 @@ let message_box title text = (* Fail and exit with error. *) let failwith text = prerr_endline text; - let text = "\n" ^ text ^ "\n\nIf you want to report this error, there is a shell on [ALT] [F2], log in as root with no password.\n\nPlease provide the contents of /tmp/virt-p2v.log and output of the 'dmesg' command." in - message_box "Error" 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 "Command failed:\n\n%s" cmd) + if Sys.command cmd <> 0 then + failwith (sprintf (f_ "Command failed:\n\n%s") cmd) let shfailok cmd = eprintf "shfailok: %s\n%!" cmd; @@ -266,8 +468,10 @@ let shget cmd = 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) + | 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). @@ -322,7 +526,7 @@ type block_device = string * int64 (* "hda" & size in bytes *) let get_lvs = let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in - function () -> + fun () -> match shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size" with @@ -346,7 +550,8 @@ let get_lvs = ) pvs in LV (vg, lv), pvs, lvsize | line -> - failwith ("lvs: unexpected output: " ^ String.concat "," line) + failwith ("lvs: " ^ s_ "unexpected output: " ^ + String.concat "," line) ) lines (* Get the partitions on a block device. @@ -388,7 +593,7 @@ let snapshot = match lines with | Some (sectors::_) -> Int64.of_string sectors | Some [] | None -> - failwith (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in + 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 /dev/%s'" @@ -406,6 +611,7 @@ let auto_network () = (* 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 @@ -415,8 +621,7 @@ let auto_network () = shfailok "ping -c3 `/sbin/ip route list match 0.0.0.0 | head -1 | awk '{print $3}'`"; if !config_greeting then ( - printf "\n\nDid automatic network configuration work?\n"; - printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n"; + 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') @@ -456,8 +661,60 @@ let remote_of_origin_dev = fun dev -> Pcre.replace ~rex:devsd ~itempl:devsd_subst dev +(* 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 state devices_to_send = +let rewrite_fstab () = let filename = "/mnt/root/etc/fstab" in if is_file filename = Some true then ( sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved")); @@ -576,8 +833,23 @@ let rec main ttyname = let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in dup2 fd stdin; dup2 fd stdout; - close fd); - printf "%s starting up ...\n%!" program_name; + 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"; @@ -585,11 +857,11 @@ let rec main ttyname = (* 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 - "You should only run this script from the live CD or a USB key."; + (s_ "You should only run this script from the live CD or a USB key."); (* Start of the information gathering phase. *) - printf "%s detecting hard drives (this may take some time) ...\n%!" - program_name; + 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 strings, like "hda". @@ -616,7 +888,8 @@ let rec main ttyname = (String.concat "; " (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices)); if devices = [] then - failwith "No non-removable block devices (hard disks, etc.) could be found on this machine."; + 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 @@ -784,14 +1057,36 @@ let rec main ttyname = ) all_partitions in - printf "finished detecting hard drives\n%!"; + print_endline (s_ "Finished detecting hard drives."); (* Autodetect system memory. *) let system_memory = - let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in - match mem with - | Some (mem::_) -> int_of_float (float_of_string mem) - | _ -> 256 in + (* 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 = @@ -809,50 +1104,29 @@ let rec main ttyname = fun () -> (* Greeting. *) if !config_greeting then - message_box program_name (sprintf "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); + 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 -> - open_centered_window ~stage:"Transfer type" - 40 10 "Transfer type"; - - let p2v = - Newt.radio_button 1 1 "Physical to virtual (P2V)" true - None in - let v2v = - Newt.radio_button 1 2 "Virtual to virtual (V2V)" false - (Some p2v) in - let ok = Newt.button 28 6 " OK " in - - let form = Newt.form None None [] in - Newt.form_add_components form [p2v; v2v]; - Newt.form_add_component form ok; + let items = [ + s_ "Physical to Virtual (P2V)", P2V; + s_ "Virtual to Virtual (V2V)", V2V; + ] in - let t = - let rec loop () = - ignore (Newt.run_form form); - - let r = Newt.radio_get_current p2v in - if Newt.component_equals r p2v then P2V - else if Newt.component_equals r v2v then V2V - else loop () - in - loop () in - - Newt.pop_window (); - - t 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:"Network" - 60 20 "Configure network"; + 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; @@ -861,8 +1135,6 @@ let rec main ttyname = * root partitions found which allow us to do * automatic configuration in a known way. *) - let partition_map = Hashtbl.create 13 in - let maplen = ref 1 in let rec loop = function | [] -> () | (partition, LinuxRoot (_, ((RHEL _|Fedora _) as distro))) @@ -871,11 +1143,7 @@ let rec main ttyname = sprintf "%s (%s)" (dev_of_partition partition) (string_of_linux_distro distro) in - Hashtbl.add partition_map (!maplen) partition; - ignore ( - Newt.listbox_append_entry autolist label (!maplen) - ); - incr maplen; + ignore (Newt.listbox_append_entry autolist label partition); loop parts | _ :: parts -> loop parts in @@ -884,40 +1152,40 @@ let rec main ttyname = (* If there is no suitable root partition (the listbox * is empty) then disable the auto option and the listbox. *) - let no_auto = Hashtbl.length partition_map = 0 in + let no_auto = Newt.listbox_item_count autolist = 0 in let auto = Newt.radio_button 1 1 - "Automatic from:" (not no_auto) None in + (s_ "Automatic from:") (not no_auto) None in let shell = Newt.radio_button 1 6 - "Start a shell" no_auto (Some auto) in + (s_ "Start a shell") no_auto (Some auto) in if no_auto then ( Newt.component_takes_focus auto false; - Newt.component_takes_focus autolist false + Newt.component_takes_focus + (Newt.component_of_listbox autolist) false ); let qemu = Newt.radio_button 1 7 - "QEMU user network" false (Some shell) in + (s_ "QEMU user network") false (Some shell) in let nonet = Newt.radio_button 1 8 - "No network or network already configured" false - (Some qemu) in + (s_ "Don't configure the network") false (Some qemu) in let static = Newt.radio_button 1 9 - "Static configuration:" false (Some nonet) in + (s_ "Static configuration:") false (Some nonet) in - let label1 = Newt.label 4 10 "Interface" 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 "Address" 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 "Netmask" 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 "Gateway" 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 "Nameserver" in + let label5 = Newt.label 4 14 (s_ "Nameserver") in let entry5 = Newt.entry 16 14 None 16 [] in let enable_static () = @@ -937,10 +1205,12 @@ let rec main ttyname = in let enable_autolist () = - Newt.component_takes_focus autolist true + Newt.component_takes_focus + (Newt.component_of_listbox autolist) true in let disable_autolist () = - Newt.component_takes_focus autolist false + Newt.component_takes_focus + (Newt.component_of_listbox autolist) false in disable_static (); @@ -955,17 +1225,15 @@ let rec main ttyname = Newt.component_add_callback static (fun () -> enable_static (); disable_autolist ()); - let ok = Newt.button 48 16 " OK " in + let ok = Newt.button 48 16 ok_button in let form = Newt.form None None [] in - Newt.form_add_component form auto; - Newt.form_add_component form autolist; - Newt.form_add_components form [shell;qemu;nonet;static]; - Newt.form_add_components form - [label1;label2;label3;label4;label5]; - Newt.form_add_components form - [entry1;entry2;entry3;entry4;entry5]; - Newt.form_add_component form ok; + 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 () = @@ -975,7 +1243,7 @@ let rec main ttyname = if Newt.component_equals r auto then ( match Newt.listbox_get_current autolist with | None -> loop () - | Some i -> Auto (Hashtbl.find partition_map i) + | Some part -> Auto part ) else if Newt.component_equals r shell then Shell else if Newt.component_equals r qemu then QEMUUserNet @@ -1005,32 +1273,26 @@ let rec main ttyname = (* Try to bring up the network. *) (match config_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%!"; + 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) -> - printf "Trying static network configuration.\n\n%!"; + print_endline (s_ "Trying static network configuration.\n"); if not (static_network (interface, address, netmask, gateway, nameserver)) 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"; + 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 -> - printf - "Trying network auto-configuration from root filesystem ...\n\n%!"; + 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 ( - 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"; + 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 () ); @@ -1040,7 +1302,7 @@ let rec main ttyname = sh ("umount -l /mnt/root"); | QEMUUserNet -> - printf "Trying QEMU network configuration.\n\n%!"; + print_endline (s_ "Trying QEMU network configuration.\n"); qemu_network () | NoNetwork -> (* this is easy ... *) () @@ -1054,62 +1316,54 @@ let rec main ttyname = | Some c -> c | None -> (* Query the user for SSH configuration. *) - open_centered_window ~stage:"SSH configuration" - 60 15 "SSH configuration"; + open_centered_window ~stage:(s_ "SSH configuration") + 60 20 (s_ "SSH configuration"); - let label1 = Newt.label 1 1 "Remote host" in + 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 "Remote port" 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 "Remote directory" 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 "SSH username" in + let label4 = Newt.label 1 4 (s_ "SSH username") in let user = Newt.entry 20 4 (Some "root") 16 [] in - let label5 = Newt.label 1 5 "SSH password" in - let pass = Newt.entry 20 5 None 16 [] in - - let check = Newt.checkbox 17 7 "Test SSH connection" '*' None in - let libvirtd = - Newt.checkbox 17 8 "libvirtd is running on host" '*' None in - - Newt.component_add_callback check - (fun () -> - if Newt.checkbox_get_value check = '*' then - Newt.component_takes_focus libvirtd true - else ( - Newt.component_takes_focus libvirtd false; - Newt.checkbox_set_value libvirtd ' ' - ) - ); + (* + 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 ok = Newt.button 48 11 " OK " 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;label5]; - Newt.form_add_components form [host;port;dir;user;pass]; - Newt.form_add_components form [check;libvirtd]; - Newt.form_add_component form ok; + 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); - try - let host = Newt.entry_get_value host in - let port = int_of_string (Newt.entry_get_value port) in - let dir = Newt.entry_get_value dir in - let user = Newt.entry_get_value user in - let pass = Newt.entry_get_value pass in - let check = Newt.checkbox_get_value check = '*' in - let libvirtd = Newt.checkbox_get_value libvirtd = '*' in - if host <> "" && port > 0 && port < 65536 && - user <> "" then - { ssh_host = host; ssh_port = port; ssh_directory = dir; - ssh_username = user; ssh_password = pass; - ssh_check = check; ssh_libvirtd = libvirtd } - else - loop () - with - Failure "int_of_string" -> loop () + 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 @@ -1117,265 +1371,272 @@ let rec main ttyname = 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"); -(* - - let ask_devices state = - let selected_devices = Option.default [] state.devices_to_send in - let devices = List.map ( - fun (dev, blksize) -> - (dev, - sprintf "/dev/%s (%.3f GB)" dev - ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)), - List.mem dev selected_devices) - ) all_block_devices in - match - checklist "Devices" "Pick devices to send" 15 50 8 devices - with - | Yes [] | No | Help | Error -> Ask_again - | Yes devices -> Next { state with devices_to_send = Some devices } - | Back -> Prev - in - - let ask_root state = - let parts = List.mapi ( - fun i (part, 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" 18 70 9 - parts - with - | Yes (i::_) -> - let (part, _) = List.nth all_partitions (int_of_string i) in - Next { state with root_filesystem = Some part } - | Yes [] | No | Help | Error -> Ask_again - | Back -> Prev - in + (* 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 "/dev/%s (%.3f GB)" 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 ask_hypervisor state = - match - radiolist "Hypervisor" - "Choose hypervisor / virtualization system" - 11 50 4 [ - "xen", "Xen", state.hypervisor = Some Xen; - "qemu", "QEMU", state.hypervisor = Some QEMU; - "kvm", "KVM", state.hypervisor = Some KVM; - "other", "Other", state.hypervisor = None - ] - with - | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen } - | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU } - | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM } - | Yes _ -> Next { state with hypervisor = None } - | No | Help | Error -> Ask_again - | Back -> Prev - in + let 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 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", "Auto-detect", - state.architecture = None || state.architecture = Some UnknownArch; - ] - with - | 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 + let libvirtd = + Newt.checkbox 12 14 (s_ "Use remote libvirtd") '*' None in - let ask_memory state = - match - inputbox "Memory" "Memory (MB). Leave blank to use same as physical server." - 10 50 - (Option.map_default string_of_int "" state.memory) - with - | Yes (""::_ | []) -> Next { state with memory = Some 0 } - | Yes (mem::_) -> - let mem = try int_of_string mem with Failure "int_of_string" -> -1 in - if mem < 0 || (mem > 0 && mem < 64) then Ask_again - else Next { state with memory = Some mem } - | No | Help | Error -> Ask_again - | Back -> Prev - in + let ok = Newt.button 28 16 ok_button in - let ask_vcpus state = - match - inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server." - 10 50 - (Option.map_default string_of_int "" state.vcpus) - with - | Yes (""::_ | []) -> Next { state with vcpus = Some 0 } - | Yes (vcpus::_) -> - let vcpus = - try int_of_string vcpus with Failure "int_of_string" -> -1 in - if vcpus < 0 then Ask_again - else Next { state with vcpus = Some vcpus } - | No | Help | Error -> Ask_again - | Back -> Prev - in + let 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 - let ask_mac_address state = - match - inputbox "MAC address" - "Network MAC address. Leave blank to use a random address." 10 50 - (Option.default "" state.mac_address) - with - | Yes (""::_ | []) -> Next { state with mac_address = Some "" } - | Yes (mac :: _) -> Next { state with mac_address = Some mac } - | No | Help | Error -> Ask_again - | Back -> Prev - in + Newt.pop_window (); - let ask_compression state = - match - radiolist "Network compression" "Enable network compression" 10 50 2 [ - "yes", "Yes, compress network traffic", state.compression <> Some false; - "no", "No, don't compress", state.compression = Some false - ] - with - | Yes ("no"::_) -> Next { state with compression = Some false } - | Yes _ -> Next { state with compression = Some true } - | No | Help | Error -> Ask_again - | Back -> Prev - in + c 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. - -Host:port: %s : %s -Directory: %s -Network: %s -Send devices: %s -Root (/) dev: %s -Hypervisor: %s -Architecture: %s -Memory: %s -VCPUs: %s -MAC address: %s -Compression: %b" - (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" - | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net" - | None -> "") - (String.concat "," (Option.default [] state.devices_to_send)) - (Option.map_default dev_of_partition "" state.root_filesystem) - (match state.hypervisor with - | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM" - | None -> "Other / not set") - (match state.architecture with - | Some 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 -> "") - (match state.vcpus with - | Some 0 -> "Same as physical" - | Some vcpus -> string_of_int vcpus | None -> "") - (match state.mac_address with - | Some "" -> "Random" | Some mac -> mac | None -> "") - (Option.default true state.compression) - ) - 21 50 - with - | Yes _ -> Next state - | Back -> Prev - | No | Help | Error -> Ask_again - in + config_devices_to_send, config_root_filesystem, config_target + ) in - (* This is the list of dialogs, in order. The user can go forwards or - * backwards through them. - * - * The second parameter in each tuple is true if we need to skip - * this dialog statically (info already supplied in 'defaults' above). - * - * The third parameter in each tuple is a function that tests whether - * this dialog should be skipped, given other parts of the current state. + (* If architecture is set to UnknownArch, then assume the same + * architecture as the live CD. *) - let dlgs = - let dont_skip _ = false in - [| - ask_greeting, not defaults.greeting, dont_skip; - ask_hostname, defaults.remote_host <> None, dont_skip; - ask_port, defaults.remote_port <> None, dont_skip; - ask_directory, defaults.remote_directory <> None, dont_skip; - ask_username, defaults.remote_username <> None, dont_skip; - ask_network, defaults.network <> None, dont_skip; - ask_static_network_config, - defaults.static_network_config <> None, - (function { network = Some Static } -> false | _ -> true); - ask_devices, defaults.devices_to_send <> None, dont_skip; - ask_root, defaults.root_filesystem <> None, dont_skip; - ask_hypervisor, defaults.hypervisor <> None, dont_skip; - ask_architecture, defaults.architecture <> None, dont_skip; - ask_memory, defaults.memory <> None, dont_skip; - ask_vcpus, defaults.vcpus <> None, dont_skip; - ask_mac_address, defaults.mac_address <> None, dont_skip; - ask_compression, defaults.compression <> None, dont_skip; - ask_verify, not defaults.greeting, dont_skip; - |] in - - (* Loop through the dialogs until we reach the end. *) - let rec loop ?(back=false) posn state = - eprintf "dialog loop: posn = %d, back = %b\n%!" posn back; - if posn >= Array.length dlgs then state (* Finished all dialogs. *) - else if posn < 0 then loop 0 state - else ( - let dlg, skip_static, skip_dynamic = dlgs.(posn) in - if skip_static || skip_dynamic state then - (* Skip this dialog. *) - loop ~back (if back then posn-1 else posn+1) state - else ( - (* Run dialog. *) - match dlg state with - | Next new_state -> loop (posn+1) new_state (* Forwards. *) - | Ask_again -> loop posn state (* Repeat the question. *) - | Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *) - ) - ) - in - let state = loop 0 defaults in - - eprintf "finished dialog loop\n%!"; - - (* In test mode, exit here before we do bad things to the developer's + 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) *) @@ -1383,28 +1644,26 @@ Compression: %b" sh "rm -f /etc/lvm.new/cache/.cache"; (* Snapshot the block devices to send. *) - let devices_to_send = Option.get state.devices_to_send in - let devices_to_send = + 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) - ) devices_to_send in + ) config_devices_to_send in (* Run kpartx on the snapshots. *) List.iter ( fun (origin, snapshot) -> shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot)) - ) devices_to_send; + ) config_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 + (match config_root_filesystem with | Part (dev, partnum) -> let dev = dev ^ partnum in let snapshot_dev = snapshot_name dev in @@ -1418,60 +1677,20 @@ Compression: %b" ); (* Work out what devices will be called at the remote end. *) - let devices_to_send = List.map ( + let config_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 + ) config_devices_to_send in (* Modify files on the root filesystem. *) - rewrite_fstab state devices_to_send; + rewrite_fstab (); (* XXX Other files to rewrite? *) (* Unmount the root filesystem and sync disks. *) sh "umount /mnt/root"; sh "sync"; (* Ugh, should be in stdlib. *) - (* Get architecture of root filesystem, detected previously. *) - let system_architecture = - try - (match List.assoc root_filesystem all_partitions with - | LinuxRoot (arch, _) -> arch - | _ -> raise Not_found - ) - with - Not_found -> - (* None was detected before, so assume same as live CD. *) - let arch = shget "uname -m" in - match arch with - | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386 - | Some ("x86_64"::_) -> X86_64 - | Some ("ia64"::_) -> IA64 - | _ -> I386 (* probably wrong XXX *) in - - 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 remote_username = Option.get state.remote_username in - - (* Functions to connect and disconnect from the remote system. *) - let do_connect remote_name _ = - let cmd = sprintf "ssh%s -l %s -p %s %s \"cat > %s/%s\"" - (if state.compression = Some false then "" else " -C") - (quote remote_username) (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. *) @@ -1482,64 +1701,55 @@ Compression: %b" "p2v-" ^ hostname ^ "-" ^ date in (* Work out what the image filenames will be at the remote end. *) - let devices_to_send = List.map ( + let config_devices_to_send = List.map ( fun (origin_dev, snapshot_dev, remote_dev) -> let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in (origin_dev, snapshot_dev, remote_dev, remote_name) - ) devices_to_send in + ) 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 For some of the stuff here we really should do a - * virConnectGetCapabilities call to the remote host first. - * * XXX There is a case for using virt-install to generate this XML. * When we start to incorporate libvirt access & storage API this * needs to be rethought. *) let conf_filename = basename ^ ".conf" in - let architecture = - match state.architecture with - | Some UnknownArch | None -> system_architecture - | Some arch -> arch in - let memory = - match state.memory with - | Some 0 | None -> system_memory - | Some memory -> memory in - let vcpus = - match state.vcpus with - | Some 0 | None -> system_nr_cpus - | Some n -> n in - let mac_address = - match state.mac_address with - | Some "" | None -> random_mac_address () - | Some mac -> mac 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 = leaf "maxmem" (string_of_int (memory * 1024)) in - let memory = leaf "memory" (string_of_int (memory * 1024)) in - let vcpu = leaf "vcpu" (string_of_int vcpus) 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 = - match state.hypervisor with + (* 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" "hvm"; - leaf "loader" "/usr/lib/xen/boot/hvmloader"; + [leaf "type" os_type; + leaf "loader" loader; tleaf "boot" ["dev", "hd"]]); Xml.Element ("features", [], [tleaf "pae" []; @@ -1547,15 +1757,14 @@ Compression: %b" tleaf "apic" []]); tleaf "clock" ["sync", "localtime"]] | Some KVM -> - [Xml.Element ("os", [], [leaf "type" "hvm"]); + [Xml.Element ("os", [], [leaf "type" os_type]); tleaf "clock" ["sync", "localtime"]] | Some QEMU -> [Xml.Element ("os", [], [Xml.Element ("type", - ["arch", - string_of_architecture architecture; - "machine","pc"], - [Xml.PCData "hvm"]); + ["arch", arch_str; + "machine", machine], + [Xml.PCData os_type]); tleaf "boot" ["dev", "hd"]])] | None -> [] in @@ -1563,18 +1772,26 @@ Compression: %b" (* section. *) let devices = let emulator = - match state.hypervisor with - | Some Xen -> - [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *) - | Some QEMU -> - [leaf "emulator" "/usr/bin/qemu"] - | Some KVM -> - [leaf "emulator" "/usr/bin/qemu-kvm"] + match caps_emulator with + (* Use the emulator from the libvirt capabilities. *) + | Some s -> [leaf "emulator" s] | None -> - [] in + (* 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", mac_address]]) in + [tleaf "mac" ["address", + config_target.tgt_mac_address]]) in (* XXX should have an option for Xen bridging: Xml.Element ( "interface", ["type","bridge"], @@ -1588,10 +1805,11 @@ Compression: %b" Xml.Element ( "disk", ["type", "file"; "device", "disk"], - [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name]; + [tleaf "source" ["file", + config_ssh.ssh_directory ^ "/" ^ remote_name]; tleaf "target" ["dev", remote_dev]] ) - ) devices_to_send in + ) config_devices_to_send in Xml.Element ( "devices", [], @@ -1601,7 +1819,7 @@ Compression: %b" (* Put it all together in . *) Xml.Element ( "domain", - (match state.hypervisor with + (match config_target.tgt_hypervisor with | Some Xen -> ["type", "xen"] | Some QEMU -> ["type", "qemu"] | Some KVM -> ["type", "kvm"] @@ -1616,25 +1834,33 @@ Compression: %b" let xml = Xml.to_string_fmt xml in let conn_arg = - match state.hypervisor with + match config_target.tgt_hypervisor with | Some Xen | None -> "" | Some QEMU | Some KVM -> " -c qemu:///system" in - let xml = sprintf "\ + let xml = sprintf (f_ "\ \n\n" conn_arg conf_filename conn_arg hostname ^ xml in +-->\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; - let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in + 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); - do_disconnect conn in + ssh_finish_upload conn in (* Send the device snapshots to the remote host. *) (* XXX This code should be made more robust against both network @@ -1649,14 +1875,15 @@ Compression: %b" 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.)); + let () = + printf (f_ "\nSending /dev/%s (%.3f GB) to remote machine\n\n%!") + 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 = do_connect remote_name size in + let (sock,_) as conn = ssh_start_upload config_ssh remote_name in (* Copy the data. *) let spinners = "|/-\\" (* "Oo" *) in @@ -1685,9 +1912,10 @@ Compression: %b" let remaining = 1. -. elapsed in let secs_remaining = (remaining /. elapsed) *. secs_elapsed in if secs_remaining > 120. then - printf " (about %.0f minutes remaining)" (secs_remaining/.60.) + printf (f_ " (about %.0f minutes remaining)") + (secs_remaining/.60.) else - printf " (about %.0f seconds remaining)" + printf (f_ " (about %.0f seconds remaining)") secs_remaining ); printf " \r%!"; @@ -1703,28 +1931,27 @@ Compression: %b" printf "\n\n%!"; (* because of the messages printed above *) (* Disconnect. *) - do_disconnect conn - ) devices_to_send; + ssh_finish_upload conn + ) config_devices_to_send; (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*) (* Clean up and reboot. *) ignore ( - msgbox (sprintf "%s completed" program_name) - (sprintf "\nThe physical to virtual migration is complete.\n\nPlease verify the disk image(s) and configuration file on the remote host, and then start up the virtual machine by doing:\n\ncd %s\nvirsh define %s\n\nWhen you press [OK] this machine will reboot." - remote_directory conf_filename) - 17 50 + 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 () = - eprintf "usage: virt-p2v [--test] [ttyname]\n%!"; + let () = eprintf (f_ "usage: virt-p2v [--test] [ttyname]\n%!") in exit 2 (* Make sure that exceptions from 'main' get printed out on stdout