remote_directory : string option;
remote_username : string option;
network : network option;
+ static_network_config : static_network_config option;
devices_to_send : string list option;
root_filesystem : partition option;
hypervisor : hypervisor option;
architecture : architecture option;
memory : int option; vcpus : int option;
mac_address : string option;
+ compression : bool option;
}
-and network = Auto | Shell
+and network = Auto
+ | Shell
+ | QEMUUserNet
+ | Static
and partition = Part of string * string (* eg. "hda", "1" *)
| LV of string * string (* eg. "VolGroup00", "LogVol00" *)
and hypervisor = Xen | QEMU | KVM
and architecture = I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
| OtherArch of string | UnknownArch
+and static_network_config = string * string * string * string * string
+ (* interface, address, netmask, gateway, nameserver *)
(*----------------------------------------------------------------------*)
(* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
devices_to_send = None;
root_filesystem = None;
network = None;
+ static_network_config = None;
hypervisor = None;
architecture = None;
memory = None;
vcpus = None;
mac_address = None;
+ compression = None;
}
(* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
(*----------------------------------------------------------------------*)
*
* Returns the exit status (Yes lines | No | Help | Back | Error).
*)
-let msgbox, yesno, inputbox, radiolist, checklist =
+let msgbox, yesno, inputbox, radiolist, checklist, form =
(* Internal function to actually run the "dialog" shell command. *)
let run_dialog cparams params =
let params = cparams @ params in
in
(* Handle the common parameters. Note Continuation Passing Style. *)
- let with_common cont ?(cancel=false) ?(backbutton=true) title =
+ let with_common cont
+ ?(cancel=false)
+ ?(backbutton=true) ?(backbutton_label="Back")
+ title =
let params = ["--title"; title] in
let params = if not cancel then "--nocancel" :: params else params in
let params =
- if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
+ if backbutton then
+ "--extra-button" :: "--extra-label" :: backbutton_label :: params
else params in
cont params
in
string_of_int listheight :: items in
run_dialog cparams items
)
+
+ (* Form. *)
+ and form =
+ with_common (
+ fun cparams text height width formheight items ->
+ let items = List.map (
+ fun (label, y, x, item, y', x', flen, ilen) ->
+ [ label; string_of_int y; string_of_int x; item;
+ string_of_int y'; string_of_int x';
+ string_of_int flen; string_of_int ilen ]
+ ) items in
+ let items = List.concat items in
+ let items = "--form" :: text ::
+ string_of_int height :: string_of_int width ::
+ string_of_int formheight :: items in
+ run_dialog cparams items
+ )
in
- msgbox, yesno, inputbox, radiolist, checklist
+ msgbox, yesno, inputbox, radiolist, checklist, form
(* Print failure dialog and exit. *)
let fail_dialog text =
(* Fedora gives an error if this file doesn't exist. *)
sh "touch /etc/resolv.conf";
-(*
- (* We can run /mnt/root/etc/init.d/network in a chroot environment,
- * however this won't work directly because the architecture of the
- * binaries under /mnt/root (eg. /mnt/root/sbin/ip) might not match
- * the architecture of the live CD kernel. In particular, a 32 bit
- * live CD cannot run 64 bit binaries. So we also have to bind-mount
- * the live CD's /bin, /sbin, /lib etc. over the equivalents in
- * /mnt/root.
- *)
- let bind dir =
- if is_dir dir = Some true then
- sh ("mount -o bind " ^ quote dir ^ " " ^ quote ("/mnt/root" ^ dir))
- in
- let unbind dir =
- if is_dir dir = Some true then sh ("umount -l " ^ quote ("/mnt/root" ^ dir))
- in
- let dirs = [
- "/bin"; "/sbin"; "/lib"; "/lib64";
- "/usr/bin"; "/usr/sbin"; "/usr/lib"; "/usr/lib64";
- "/proc"; "/sys"
- ] in
- List.iter bind dirs;
- let status = shwithstatus "chroot /mnt/root /etc/init.d/network start" in
- List.iter unbind dirs;
-*)
-
- (* Simpler way to do the above.
- * NB. Lazy unmount is required because dhclient keeps its current
+ (* NB. Lazy unmount is required because dhclient keeps its current
* directory open on /etc/sysconfig/network-scripts/
*)
sh "mount -o bind /mnt/root/etc /etc";
(* Non-interactive: return the status of /etc/init.d/network start. *)
status = 0
+(* Configure the network statically. *)
+let static_network state =
+ match state.static_network_config with
+ | None -> false (* failed *)
+ | Some (interface, address, netmask, gateway, nameserver) ->
+ let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
+ try
+ do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
+ (quote interface) (quote address) (quote netmask));
+ do_cmd_or_exit (sprintf "route add default gw %s %s"
+ (quote gateway) (quote interface));
+ if nameserver <> "" then
+ do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
+ (quote nameserver));
+ true (* succeeded *)
+ with
+ Exit -> false (* failed *)
+
+let qemu_network () =
+ sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0";
+ sh "route add default gw 10.0.2.2 eth0";
+ sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"
+
(* Map local device names to remote devices names. At the moment we
* just change sd* to hd* (as device names appear under fullvirt). In
* future, lots of complex possibilities.
fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
dev mountpoint fstype options freq passno
| line ->
- output_string chan (String.concat " " line)
+ output_string chan (String.concat " " line);
+ output_char chan '\n'
) lines;
close_out chan
)
+let () = Random.self_init ()
+
+let random_mac_address () =
+ let random =
+ List.map (sprintf "%02x") (
+ List.map (fun _ -> Random.int 256) [0;0;0]
+ ) in
+ String.concat ":" ("00"::"16"::"3e"::random)
+
+let random_uuid =
+ let hex = "0123456789abcdef" in
+ fun () ->
+ let str = String.create 32 in
+ for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
+ str
+
(* Main entry point. *)
let rec main ttyname =
(* Running from an init script. We don't have much of a
let ask_network state =
match
- radiolist "Network configuration" "Network configuration" 10 50 2 [
+ radiolist "Network configuration" "Network configuration" 12 50 4 [
"auto", "Automatic configuration", state.network = Some Auto;
+ "ask", "Ask for fixed IP address and gateway",
+ state.network = Some Static;
"sh", "Configure from the shell", state.network = Some Shell;
+ "qemu", "QEMU user network (for developers only)",
+ state.network = Some QEMUUserNet
]
with
| Yes ("auto"::_) -> Next { state with network = Some Auto }
+ | Yes ("ask"::_) -> Next { state with network = Some Static }
| Yes ("sh"::_) -> Next { state with network = Some Shell }
+ | Yes ("qemu"::_) -> Next { state with network = Some QEMUUserNet }
+ | Yes _ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
+ let ask_static_network_config state =
+ let interface, address, netmask, gateway, nameserver =
+ match state.static_network_config with
+ | Some (a,b,c,d,e) -> a,b,c,d,e
+ | None -> "eth0","","","","" in
+ match
+ form "Static network configuration" "Static network configuration"
+ 13 50 5 [
+ "Interface", 1, 0, interface, 1, 12, 8, 0;
+ "Address", 2, 0, address, 2, 12, 16, 0;
+ "Netmask", 3, 0, netmask, 3, 12, 16, 0;
+ "Gateway", 4, 0, gateway, 4, 12, 16, 0;
+ "Nameserver", 5, 0, nameserver, 5, 12, 16, 0;
+ ]
+ with
+ | Yes (interface::address::netmask::gateway::nameserver::_) ->
+ Next { state with
+ static_network_config = Some (interface, address, netmask,
+ gateway, nameserver) }
| Yes _ | No | Help | Error -> Ask_again
| Back -> Prev
in
| Back -> Prev
in
+ let ask_compression state =
+ match
+ radiolist "Network compression" "Enable network compression" 10 50 2 [
+ "yes", "Yes, compress network traffic", state.compression <> Some false;
+ "no", "No, don't compress", state.compression = Some false
+ ]
+ with
+ | Yes ("no"::_) -> Next { state with compression = Some false }
+ | Yes _ -> Next { state with compression = Some true }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
let ask_verify state =
match
yesno "Verify and proceed"
Architecture: %s
Memory: %s
VCPUs: %s
-MAC address: %s"
+MAC address: %s
+Compression: %b"
(Option.default "" state.remote_host)
(Option.default "" state.remote_port)
(Option.default "" state.remote_directory)
(match state.network with
| Some Auto -> "Auto-configure" | Some Shell -> "Shell"
+ | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net"
| None -> "")
(String.concat "," (Option.default [] state.devices_to_send))
(Option.map_default dev_of_partition "" state.root_filesystem)
| Some vcpus -> string_of_int vcpus | None -> "")
(match state.mac_address with
| Some "" -> "Random" | Some mac -> mac | None -> "")
+ (Option.default true state.compression)
)
21 50
with
in
(* This is the list of dialogs, in order. The user can go forwards or
- * backwards through them. The second parameter in each pair is
- * false if we need to skip this dialog (info already supplied in
- * 'defaults' above).
+ * backwards through them.
+ *
+ * The second parameter in each tuple is true if we need to skip
+ * this dialog statically (info already supplied in 'defaults' above).
+ *
+ * The third parameter in each tuple is a function that tests whether
+ * this dialog should be skipped, given other parts of the current state.
*)
- let dlgs = [|
- ask_greeting, (* Initial greeting. *)
- defaults.greeting;
- ask_hostname, (* Hostname. *)
- defaults.remote_host = None;
- ask_port, (* Port number. *)
- defaults.remote_port = None;
- ask_directory, (* Remote directory. *)
- defaults.remote_directory = None;
- ask_username, (* Remote username. *)
- defaults.remote_username = None;
- ask_network, (* Network configuration. *)
- defaults.network = None;
- ask_devices, (* Block devices to send. *)
- defaults.devices_to_send = None;
- ask_root, (* Root filesystem. *)
- defaults.root_filesystem = None;
- ask_hypervisor, (* Hypervisor. *)
- defaults.hypervisor = None;
- ask_architecture, (* Architecture. *)
- defaults.architecture = None;
- ask_memory, (* Memory. *)
- defaults.memory = None;
- ask_vcpus, (* VCPUs. *)
- defaults.vcpus = None;
- ask_mac_address, (* MAC address. *)
- defaults.mac_address = None;
- ask_verify, (* Verify settings. *)
- defaults.greeting
+ let dlgs =
+ let dont_skip _ = false in
+ [|
+ ask_greeting, not defaults.greeting, dont_skip;
+ ask_hostname, defaults.remote_host <> None, dont_skip;
+ ask_port, defaults.remote_port <> None, dont_skip;
+ ask_directory, defaults.remote_directory <> None, dont_skip;
+ ask_username, defaults.remote_username <> None, dont_skip;
+ ask_network, defaults.network <> None, dont_skip;
+ ask_static_network_config,
+ defaults.static_network_config <> None,
+ (function { network = Some Static } -> false | _ -> true);
+ ask_devices, defaults.devices_to_send <> None, dont_skip;
+ ask_root, defaults.root_filesystem <> None, dont_skip;
+ ask_hypervisor, defaults.hypervisor <> None, dont_skip;
+ ask_architecture, defaults.architecture <> None, dont_skip;
+ ask_memory, defaults.memory <> None, dont_skip;
+ ask_vcpus, defaults.vcpus <> None, dont_skip;
+ ask_mac_address, defaults.mac_address <> None, dont_skip;
+ ask_compression, defaults.compression <> None, dont_skip;
+ ask_verify, not defaults.greeting, dont_skip;
|] in
(* Loop through the dialogs until we reach the end. *)
- let rec loop posn state =
- eprintf "dialog loop: posn = %d\n%!" posn;
+ let rec loop ?(back=false) posn state =
+ eprintf "dialog loop: posn = %d, back = %b\n%!" posn back;
if posn >= Array.length dlgs then state (* Finished all dialogs. *)
+ else if posn < 0 then loop 0 state
else (
- let dlg, no_skip = dlgs.(posn) in
- let skip = not no_skip in
- if skip then
- (* Skip this dialog and move straight to the next one. *)
- loop (posn+1) state
+ let dlg, skip_static, skip_dynamic = dlgs.(posn) in
+ if skip_static || skip_dynamic state then
+ (* Skip this dialog. *)
+ loop ~back (if back then posn-1 else posn+1) state
else (
(* Run dialog. *)
match dlg state with
| Next new_state -> loop (posn+1) new_state (* Forwards. *)
- | Prev -> loop (posn-1) state (* Backwards / back button. *)
- | Ask_again -> loop posn state (* Repeat the question. *)
+ | Ask_again -> loop posn state (* Repeat the question. *)
+ | Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *)
)
)
in
printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
shell ()
+ | Static ->
+ printf "Trying static network configuration.\n\n%!";
+ if not (static_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 ()
+ )
+
| Auto ->
printf
"Trying network auto-configuration from root filesystem ...\n\n%!";
printf "When you have finished, exit the shell with ^D or exit.\n\n";
shell ()
)
+ | QEMUUserNet ->
+ printf "Trying QEMU network configuration.\n\n%!";
+ qemu_network ()
);
(* Work out what devices will be called at the remote end. *)
(* Functions to connect and disconnect from the remote system. *)
let do_connect remote_name _ =
- let cmd = sprintf "ssh -C -l %s -p %s %s \"cat > %s/%s\""
+ let cmd = sprintf "ssh%s -l %s -p %s %s \"cat > %s/%s\""
+ (if state.compression = Some false then "" else " -C")
(quote remote_username) (quote remote_port) (quote remote_host)
(quote remote_directory) (quote remote_name) in
eprintf "connect: %s\n%!" cmd;
| 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 "" | None -> random_mac_address ()
| Some mac -> mac in
let xml =
(* 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
| Some QEMU -> ["type", "qemu"]
| Some KVM -> ["type", "kvm"]
| None -> []),
- name :: memory :: vcpu :: extras @ [devices]
+ name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
) in
(* Convert XML configuration file to a string, then send it to the
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 n' = write sock buffer 0 n in
+ if n <> n' then assert false; (* never, according to the manual *)
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 (
+ (* Print progress every few seconds. *)
+ if now -. last_printed_at > 5. then (
let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
let secs_elapsed = now -. start in
- printf "%.0f%%" (100. *. elapsed);
+ printf "%.0f%% @ %.1f Mbps"
+ (100. *. elapsed)
+ (Int64.to_float bytes_sent/.secs_elapsed/.1_000_000. *. 8.);
(* 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.)
+ printf " (about %.0f minutes remaining)" (secs_remaining/.60.)
else
- printf " (about %.0f seconds remaining) "
+ printf " (about %.0f seconds remaining)"
secs_remaining
);
- printf "\r%!";
+ printf " \r%!";
now
)
else last_printed_at in
)
in
copy 0L start;
+ printf "\n\n%!"; (* because of the messages printed above *)
(* Disconnect. *)
do_disconnect conn
) devices_to_send;
+ (*printf "\n\nPress any key ...\n%!"; ignore (read_line ());*)
+
(* Clean up and reboot. *)
ignore (
msgbox "virt-p2v completed"
git.annexia.org / virt-p2v.git / blobdiff