(handle, rb)
) items in
- let ok = Newt.button 48 16 " OK " in
+ let ok = Newt.button (width-12) 16 " OK " in
let vb =
if List.length entries > 10 then
(* 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
| WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
| WSTOPPED i -> failwith (sprintf "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 =
printf "Testing SSH connection by listing files in remote directory ...\n\n%!";
true
(* Rewrite /mnt/root/etc/fstab. *)
-let rewrite_fstab state devices_to_send =
+let rewrite_fstab devices_to_send =
let filename = "/mnt/root/etc/fstab" in
if is_file filename = Some true then (
sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
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. *)
+ (* 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, _) ->
{ tgt_hypervisor = Option.get hv;
tgt_architecture = Option.get arch;
tgt_memory = mem; tgt_vcpus = cpus;
- tgt_mac_address = mac;
+ tgt_mac_address =
+ if mac <> "" then mac else random_mac_address ();
tgt_libvirtd = libvirtd }
else
loop ()
config_devices_to_send, config_root_filesystem, config_target
) in
-
-
-
-
-(*
- (* In test mode, exit here before we do bad things to the developer's
+ (* In test mode, exit here before we do Bad Things to the developer's
* hard disk.
*)
if test_dialog_stages then exit 1;
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
);
(* 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 config_devices_to_send;
(* 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. *)
+ (* 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
- 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
+ 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.
"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
*)
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 "<name>value</name>". *)
let leaf name value = Xml.Element (name, [], [Xml.PCData value]) 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 =
+ leaf "maxmem" (string_of_int (config_target.tgt_memory * 1024)) in
+ m, 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
+ match config_target.tgt_hypervisor with
| Some Xen ->
[Xml.Element ("os", [],
[leaf "type" "hvm";
[Xml.Element ("os", [],
[Xml.Element ("type",
["arch",
- string_of_architecture architecture;
+ string_of_architecture
+ config_target.tgt_architecture;
"machine","pc"],
[Xml.PCData "hvm"]);
tleaf "boot" ["dev", "hd"]])]
(* <devices> section. *)
let devices =
let emulator =
- match state.hypervisor with
+ match config_target.tgt_hypervisor with
| Some Xen ->
[leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
| Some QEMU ->
[] 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"],
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", [],
(* Put it all together in <domain type='foo'>. *)
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"]
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_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
+ 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
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
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)
+ message_box (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
+ config_ssh.ssh_directory conf_filename)
);
shfailok "eject";
shfailok "reboot";
-*)
+
exit 0
(*----------------------------------------------------------------------*)
git.annexia.org / virt-p2v.git / commitdiff