+ (* See if we can do network configuration. *)
+ let network = Option.get state.network in
+ (match 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%!";
+ shell ()
+
+ | Auto ->
+ printf
+ "Trying network auto-configuration from root filesystem ...\n\n%!";
+ if not (auto_network state) 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";
+ shell ()
+ )
+ );
+
+ (* Work out what devices will be called at the remote end. *)
+ let 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
+
+ (* Modify files on the root filesystem. *)
+ rewrite_fstab state devices_to_send;
+ (* XXX Other files to rewrite? *)
+
+ (* XXX Autodetect architecture of root filesystem by looking for /bin/ls. *)
+ let system_architecture = X86_64 in
+
+ (* XXX Autodetect system memory. *)
+ let system_memory = 256 in
+
+ (* XXX Autodetect system # pCPUs. *)
+ let system_nr_cpus = 1 in
+
+ (* Unmount the root filesystem and sync disks. *)
+ sh "umount /mnt/root";
+ sh "sync"; (* Ugh, should be in stdlib. *)
+
+ (* Disable screen blanking on console. *)
+ sh "setterm -blank 0";
+
+ 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
+
+ (* Functions to connect and disconnect from the remote system. *)
+ let do_connect remote_name _ =
+ let cmd = sprintf "ssh -C -p %s %s \"cat > %s/%s\""
+ (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.
+ *)
+ 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 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 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 ->
+ 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",
+ string_of_architecture 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,_) as conn = 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 conn;
+
+ (* 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%!" origin_dev remote_name;
+
+ let size =
+ 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.));
+
+ (* 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
+
+ (* Copy the data. *)
+ let bufsize = 1024 * 1024 in
+ let buffer = String.create bufsize in
+ let start = gettimeofday () in
+
+ let rec copy bytes_sent last_printed_at =
+ let n = read fd buffer 0 bufsize in
+ if n > 0 then (
+ ignore (write sock buffer 0 n);
+
+ let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
+ let last_printed_at =
+ let now = gettimeofday () in
+ (* Print progress once per second. *)
+ if now -. last_printed_at > 1. then (
+ let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
+ let secs_elapsed = now -. start in
+ printf "%.0f%%" (100. *. elapsed);
+ (* 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 " (about %.0f minutes remaining) "
+ (secs_remaining /. 60.)
+ else
+ printf " (about %.0f seconds remaining) "
+ secs_remaining
+ );
+ printf "\r%!";
+ now
+ )
+ else last_printed_at in
+
+ copy bytes_sent last_printed_at
+ )
+ in
+ copy 0L start;
+
+ (* Disconnect. *)
+ do_disconnect conn
+ ) devices_to_send;
+
+ (* Clean up and reboot. *)
+ ignore (
+ msgbox "virt-p2v completed"
+ (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
+ );
+
+ shfailok "eject";
+ shfailok "reboot";
+ exit 0