| 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. *)
| 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: *)
| 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
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;
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 <os_type>hvm</os_type>
+ * and <arch name="target-arch">... 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.
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.
*)
* 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.
(* ... 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" [];
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
(* <devices> 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",
| Some QEMU | Some KVM -> " -c qemu:///system" in
let xml = sprintf "\
<!--
- This is a libvirt configuration file.
+ This is an automatically generated libvirt configuration file.
+ It was written by the %s program.
+
+ Please check the values in this configuration file carefully,
+ particularly maxmem, memory, vcpu and any paths.
To start the domain, do:
virsh%s define %s
virsh%s start %s
--->\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);
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. *)
git.annexia.org / virt-p2v.git / commitdiff