Require fixed libvirt.

[virt-p2v.git] / virt-p2v

diff --git a/virt-p2v b/virt-p2v
index 8c4498c..4e27c77 100755 (executable)
--- a/virt-p2v
+++ b/virt-p2v
@@ -305,7 +305,7 @@ let select_single ?stage width title items =
            (handle, rb)
        ) items in
 
            (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
 
       let vb =
        if List.length entries > 10 then


@@ -502,6 +502,7 @@ let auto_network () =
 
   (* NB. Lazy unmount is required because dhclient keeps its current
    * directory open on /etc/sysconfig/network-scripts/
 
   (* 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
    *)
   sh "mount -o bind /mnt/root/etc /etc";
   let status = shwithstatus "/etc/init.d/network start" in


@@ -578,6 +579,14 @@ let ssh_disconnect (_, chan) =
   | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
   | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
 
   | 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%!";
 (* Test SSH connection. *)
 let test_ssh config =
   printf "Testing SSH connection by listing files in remote directory ...\n\n%!";


@@ -597,7 +606,7 @@ let test_ssh config =
     true
 
 (* Rewrite /mnt/root/etc/fstab. *)
     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"));
   let filename = "/mnt/root/etc/fstab" in
   if is_file filename = Some true then (
     sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));


@@ -1288,7 +1297,10 @@ let rec main ttyname =
              Newt.listbox_append_entry archlistbox "SPARC 64-bit" SPARC64;
              Newt.listbox_append_entry archlistbox "Unknown/other" UnknownArch;
 
              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, _) ->
              (try
                 match List.assoc config_root_filesystem all_partitions with
                 | LinuxRoot (arch, _) ->


@@ -1337,7 +1349,8 @@ let rec main ttyname =
                      { tgt_hypervisor = Option.get hv;
                        tgt_architecture = Option.get arch;
                        tgt_memory = mem; tgt_vcpus = cpus;
                      { 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 ()
                        tgt_libvirtd = libvirtd }
                    else
                      loop ()


@@ -1353,12 +1366,7 @@ let rec main ttyname =
        config_devices_to_send, config_root_filesystem, config_target
     ) in
 
        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;
    * hard disk.
    *)
   if test_dialog_stages then exit 1;


@@ -1370,28 +1378,26 @@ let rec main ttyname =
   sh "rm -f /etc/lvm.new/cache/.cache";
 
   (* Snapshot the block devices to send. *)
   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)
     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))
 
   (* 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. *)
 
   (* 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
    | Part (dev, partnum) ->
        let dev = dev ^ partnum in
        let snapshot_dev = snapshot_name dev in


@@ -1405,41 +1411,35 @@ let rec main ttyname =
   );
 
   (* Work out what devices will be called at the remote end. *)
   );
 
   (* 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)
     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. *)
 
   (* 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. *)
 
   (* 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
        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.
 
   (* XXX This is using the hostname derived from network configuration
    * above.  We might want to ask the user to choose.


@@ -1451,11 +1451,11 @@ let rec main ttyname =
     "p2v-" ^ hostname ^ "-" ^ date in
 
   (* Work out what the image filenames will be at the remote end. *)
     "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)
     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
 
   (* 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


@@ -1470,23 +1470,6 @@ let rec main ttyname =
    *)
   let conf_filename = basename ^ ".conf" in
 
    *)
   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
   let xml =
     (* Shortcut to make "<name>value</name>". *)
     let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in


@@ -1496,15 +1479,17 @@ let rec main ttyname =
     (* Standard stuff for every domain. *)
     let name = leaf "name" hostname in
     let uuid = leaf "uuid" (random_uuid ()) 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 =
 
     (* 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";
       | Some Xen ->
          [Xml.Element ("os", [],
                        [leaf "type" "hvm";


@@ -1522,7 +1507,8 @@ let rec main ttyname =
          [Xml.Element ("os", [],
                        [Xml.Element ("type",
                                      ["arch",
          [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"]])]
                                       "machine","pc"],
                                      [Xml.PCData "hvm"]);
                         tleaf "boot" ["dev", "hd"]])]


@@ -1532,7 +1518,7 @@ let rec main ttyname =
     (* <devices> section. *)
     let devices =
       let emulator =
     (* <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 ->
        | Some Xen ->
            [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
        | Some QEMU ->


@@ -1543,7 +1529,8 @@ let rec main ttyname =
            [] in
       let interface =
        Xml.Element ("interface", ["type", "user"],
            [] 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"],
       (* XXX should have an option for Xen bridging:
        Xml.Element (
        "interface", ["type","bridge"],


@@ -1557,10 +1544,11 @@ let rec main ttyname =
          Xml.Element (
            "disk", ["type", "file";
                     "device", "disk"],
          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]]
          )
             tleaf "target" ["dev", remote_dev]]
          )

-      ) devices_to_send in
+      ) config_devices_to_send in

 
       Xml.Element (
        "devices", [],
 
       Xml.Element (
        "devices", [],


@@ -1570,7 +1558,7 @@ let rec main ttyname =
     (* Put it all together in <domain type='foo'>. *)
     Xml.Element (
       "domain",
     (* 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"]
        | Some Xen -> ["type", "xen"]
        | Some QEMU -> ["type", "qemu"]
        | Some KVM -> ["type", "kvm"]


@@ -1585,7 +1573,7 @@ let rec main ttyname =
     let xml = Xml.to_string_fmt xml in
 
     let conn_arg =
     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 "\
       | Some Xen | None -> ""
       | Some QEMU | Some KVM -> " -c qemu:///system" in
     let xml = sprintf "\


@@ -1600,10 +1588,10 @@ let rec main ttyname =
     let xml_len = String.length xml in
     eprintf "length of configuration file is %d bytes\n%!" xml_len;
 
     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);
     (* 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
 
   (* Send the device snapshots to the remote host. *)
   (* XXX This code should be made more robust against both network


@@ -1625,7 +1613,7 @@ let rec main ttyname =
       let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
 
       (* Now connect. *)
       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
 
       (* Copy the data. *)
       let spinners = "|/-\\" (* "Oo" *) in


@@ -1672,22 +1660,21 @@ let rec main ttyname =
       printf "\n\n%!"; (* because of the messages printed above *)
 
       (* Disconnect. *)
       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 (
 
   (*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."
       (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";
   );
 
   shfailok "eject";
   shfailok "reboot";

-*)
+

   exit 0
 
 (*----------------------------------------------------------------------*)
   exit 0
 
 (*----------------------------------------------------------------------*)