From: Richard W.M. Jones <"Richard W.M. Jones "> Date: Wed, 19 Mar 2008 17:52:16 +0000 (+0000) Subject: libvirt capabilities parsed and incorporated into the generated config file. X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;ds=sidebyside;h=831c069af0145b3520157bdcab4845be554c4cee;p=virt-p2v.git libvirt capabilities parsed and incorporated into the generated config file. --- diff --git a/virt-p2v b/virt-p2v index 922ad40..ca75df9 100755 --- a/virt-p2v +++ b/virt-p2v @@ -51,6 +51,8 @@ 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. *) @@ -159,6 +161,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: *) @@ -184,6 +212,45 @@ and string_of_linux_distro = function | 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 @@ -1390,10 +1457,24 @@ let rec main ttyname = 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 capabilities = + let caps_os_type, caps_emulator, caps_loader, caps_machine = try if not config_target.tgt_libvirtd then raise Not_found; @@ -1406,23 +1487,96 @@ let rec main ttyname = sprintf "%s+ssh://%s@%s:%s%s" proto config_ssh.ssh_username config_ssh.ssh_host config_ssh.ssh_port path in - eprintf "fetch capabilities from %S\n%!" name; + eprintf "capabilities URI = %S\n%!" name; + + printf "Try to fetch remote hypervisor capabilities ...\n\n%!"; let conn = Libvirt.Connect.connect_readonly ~name () in let caps = Libvirt.Connect.get_capabilities conn in Libvirt.Connect.close conn; - eprintf "capabilities:\n%s\n%!" caps; - - Some caps + (* 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 "Warning" + (sprintf "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 "Note" + (sprintf "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 + | 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, None | Invalid_argument str -> eprintf "libvirt error: %s\n%!" str; - None in + None, None, None, None in (* In test mode, exit here before we do Bad Things to the developer's * hard disk. @@ -1483,22 +1637,6 @@ let rec main ttyname = sh "umount /mnt/root"; sh "sync"; (* Ugh, should be in stdlib. *) - (* 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 (("i386"|"i486"|"i586"|"i686")::_) -> I386 - | Some ("x86_64"::_) -> X86_64 - | Some ("ia64"::_) -> IA64 - | _ -> I386 (* probably wrong XXX *) in - { config_target with tgt_architecture = arch } - | _ -> config_target in - (* XXX This is using the hostname derived from network configuration * above. We might want to ask the user to choose. *) @@ -1519,9 +1657,6 @@ let rec main ttyname = * 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. @@ -1534,24 +1669,33 @@ let rec main ttyname = (* ... 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 = - leaf "maxmem" (string_of_int (config_target.tgt_memory * 1024)) in - m, m in + 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" "hvm"; - leaf "loader" "/usr/lib/xen/boot/hvmloader"; + [leaf "type" os_type; + leaf "loader" loader; tleaf "boot" ["dev", "hd"]]); Xml.Element ("features", [], [tleaf "pae" []; @@ -1559,16 +1703,14 @@ let rec main ttyname = 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 - config_target.tgt_architecture; - "machine","pc"], - [Xml.PCData "hvm"]); + ["arch", arch_str; + "machine", machine], + [Xml.PCData os_type]); tleaf "boot" ["dev", "hd"]])] | None -> [] in @@ -1576,15 +1718,22 @@ let rec main ttyname = (* section. *) let devices = let emulator = - match config_target.tgt_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", @@ -1636,16 +1785,24 @@ let rec main ttyname = | Some QEMU | Some KVM -> " -c qemu:///system" in let xml = sprintf "\ \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; + printf "\nWriting configuration file ...\n\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); @@ -1664,7 +1821,7 @@ let rec main ttyname = 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 + printf "\nSending /dev/%s (%.3f GB) to remote machine\n\n%!" origin_dev ((Int64.to_float size) /. (1024.*.1024.*.1024.)); (* Open the snapshot device. *)