+ (* Work out what the image filenames will be at the remote end. *)
+ let 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
+
+ (* 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 "" | None -> system_architecture
+ | Some arch -> arch in
+ let memory =
+ match state.memory with
+ | Some memory -> memory
+ | None -> system_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 ->
+ let random =
+ List.map (sprintf "%02x") (
+ List.map (fun _ -> Random.int 256) [0;0;0]
+ ) in
+ String.concat ":" ("00"::"16"::"3e"::random)
+ | Some mac -> mac in
+
+ let xml =
+ (* Shortcut to make "<name>value</name>". *)
+ 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
+
+ (* Standard stuff for every domain. *)
+ let name = leaf "name" hostname in
+ let memory = leaf "memory" (string_of_int (memory * 1024)) in
+ let vcpu = leaf "vcpu" (string_of_int vcpus) in
+
+ (* Top-level stuff which differs for each HV type (isn't this supposed
+ * to be portable ...)
+ *)
+ let extras =
+ match state.hypervisor with
+ | Some Xen ->
+ [Xml.Element ("os", [],
+ [leaf "type" "hvm";
+ leaf "loader" "/usr/lib/xen/boot/hvmloader";
+ tleaf "boot" ["dev", "hd"]]);
+ Xml.Element ("features", [],
+ [tleaf "pae" [];
+ tleaf "acpi" [];
+ tleaf "apic" []]);
+ tleaf "clock" ["sync", "localtime"]]
+ | Some KVM ->
+ [Xml.Element ("os", [], [leaf "type" "hvm"]);
+ tleaf "clock" ["sync", "localtime"]]
+ | Some QEMU ->
+ [Xml.Element ("os", [],
+ [Xml.Element ("type", ["arch",architecture;
+ "machine","pc"],
+ [Xml.PCData "hvm"]);
+ tleaf "boot" ["dev", "hd"]])]
+ | None ->
+ [] in
+
+ (* <devices> 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"]
+ | None ->
+ [] in
+ let interface =
+ Xml.Element ("interface", ["type", "user"],
+ [tleaf "mac" ["address", 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", remote_directory ^ "/" ^ remote_name];
+ tleaf "target" ["dev", remote_dev]]
+ )
+ ) devices_to_send in
+
+ Xml.Element (
+ "devices", [],
+ emulator @ interface :: graphics :: disks
+ ) in
+
+ (* Put it all together in <domain type='foo'>. *)
+ Xml.Element (
+ "domain",
+ (match state.hypervisor with
+ | Some Xen -> ["type", "xen"]
+ | Some QEMU -> ["type", "qemu"]
+ | Some KVM -> ["type", "kvm"]
+ | None -> []),
+ name :: memory :: vcpu :: extras @ [devices]
+ ) in
+
+ let xml = Xml.to_string_fmt xml in
+ let xml_len = String.length xml in
+ eprintf "length of configuration file is %d bytes\n%!" xml_len;
+
+ let sock = do_connect conf_filename (Int64.of_int xml_len) in
+ (* In OCaml this actually loops calling write(2) *)
+ ignore (write sock xml 0 xml_len);
+ do_disconnect sock;
+
+ (* Send the device snapshots to the remote host. *)