#load "extLib.cma";;
#directory "+pcre";;
#load "pcre.cma";;
+#directory "+xml-light";;
+#load "xml-light.cma";;
(* virt-p2v.ml is a script which performs a physical to
* virtual conversion of local disks.
remote_directory : string option;
network : network option;
devices_to_send : string list option;
- root_filesystem : partition option }
-and transport = Server | SSH | TCP
+ root_filesystem : partition option;
+ hypervisor : hypervisor option;
+ architecture : string option;
+ memory : int option; vcpus : int option;
+ mac_address : string option;
+ }
+and transport = Server | SSH
and network = Auto | Shell
and partition = Part of string * string (* eg. "hda", "1" *)
| LV of string * string (* eg. "VolGroup00", "LogVol00" *)
+and hypervisor = Xen | QEMU | KVM
(*----------------------------------------------------------------------*)
(* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
*)
greeting = true;
- (* Transport: Set to 'Some Server' or 'Some SSH' or 'Some TCP' to
- * assume Server, SSH or TCP transports respectively.
+ (* Transport: Set to 'Some Server' or 'Some SSH' to assume Server or SSH
+ * transports respectively.
*)
transport = None;
* automatically, or 'Some Shell' (give the user a shell).
*)
network = None;
+
+ (* Hypervisor: Set to 'Some Xen', 'Some QEMU' or 'Some KVM'. *)
+ hypervisor = None;
+
+ (* Architecture: Set to 'Some "x86_64"' (or another architecture).
+ * If set to 'Some ""' then we try to autodetect the right architecture.
+ *)
+ architecture = None;
+
+ (* Memory: Set to 'Some nn' with nn in megabytes. If set to 'Some 0'
+ * then we use same amount of RAM as installed in the physical machine.
+ *)
+ memory = None;
+
+ (* Virtual CPUs: Set to 'Some nn' where nn is the number of virtual CPUs.
+ * If set to 'Some 0' then we use the same as physical CPUs in the
+ * physical machine.
+ *)
+ vcpus = None;
+
+ (* MAC address: Set to 'Some "aa:bb:cc:dd:ee:ff"' where the string is
+ * the MAC address of the emulated network card. Set to 'Some ""' to
+ * choose a random MAC address.
+ *)
+ mac_address = None;
}
(* END OF CUSTOM virt-p2v SCRIPT SECTION. *)
(*----------------------------------------------------------------------*)
with
End_of_file -> List.rev !lines
-let rec string_of_state state =
- sprintf
- "greeting: %b remote: %s:%s%s%s network: %s devices: [%s] root: %s"
- state.greeting
- (Option.default "" state.remote_host)
- (Option.default "" state.remote_port)
- (match state.transport with
- | None -> ""
- | Some Server -> " (server)" | Some SSH -> " (ssh)" | Some TCP -> " (tcp)")
- (match state.remote_directory with
- | None -> "" | Some dir -> " " ^ dir)
- (match state.network with
- | None -> "none" | Some Auto -> "auto" | Some Shell -> "shell")
- (String.concat "; " (Option.default [] state.devices_to_send))
- (Option.map_default dev_of_partition "" state.root_filesystem)
-
-and dev_of_partition = function
+let dev_of_partition = function
| Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
| LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
(* Dialogs. *)
let ask_greeting state =
- ignore (msgbox "virt-p2v" "\nUPDATED! Welcome to virt-p2v, a live CD for migrating a physical machine to a virtualized host.\n\nTo continue press the Return key.\n\nTo get a shell you can use [ALT] [F2] and log in as root with no password.\n\nExtra information is logged in /tmp/virt-p2v.log but this file disappears when the machine reboots." 18 50);
+ ignore (msgbox "virt-p2v" "\nWelcome to virt-p2v, a live CD for migrating a physical machine to a virtualized host.\n\nTo continue press the Return key.\n\nTo get a shell you can use [ALT] [F2] and log in as root with no password.\n\nExtra information is logged in /tmp/virt-p2v.log but this file disappears when the machine reboots." 18 50);
Next state
in
let ask_transport state =
match
radiolist "Connection type" ~backbutton:false
- "Connection type. If possible, select 'server' and run P2V server on the remote host"
- 11 50 3 [
- "server", "P2V server on remote host",
- state.transport = Some Server;
- "ssh", "SSH (secure shell)",
- state.transport = Some SSH;
- "tcp", "TCP socket",
- state.transport = Some TCP
+ "Connection type."
+ 11 50 2 [
+ "ssh", "SSH (secure shell)", state.transport = Some SSH;
+ "server", "P2V server on remote host", state.transport = Some Server
]
with
- | Yes ("server"::_) -> Next { state with transport = Some Server }
| Yes ("ssh"::_) -> Next { state with transport = Some SSH }
- | Yes ("tcp"::_) -> Next { state with transport = Some TCP }
+ | Yes ("server"::_) -> Next { state with transport = Some Server }
| Yes _ | No | Help | Error -> Ask_again
| Back -> Prev
in
| Back -> Prev
in
+ let ask_hypervisor state =
+ match
+ radiolist "Hypervisor"
+ "Choose hypervisor / virtualization system"
+ 11 50 4 [
+ "xen", "Xen", state.hypervisor = Some Xen;
+ "qemu", "QEMU", state.hypervisor = Some QEMU;
+ "kvm", "KVM", state.hypervisor = Some KVM;
+ "other", "Other", state.hypervisor = None
+ ]
+ with
+ | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
+ | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
+ | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
+ | Yes _ -> Next { state with hypervisor = None }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
+ let ask_architecture state =
+ match
+ radiolist "Architecture" "Machine architecture" 16 50 8 [
+ "i386", "i386 and up (32 bit)", state.architecture = Some "i386";
+ "x86_64", "x86-64 (64 bit)", state.architecture = Some "x86_64";
+ "ia64", "Itanium IA64", state.architecture = Some "ia64";
+ "ppc", "PowerPC (32 bit)", state.architecture = Some "ppc";
+ "ppc64", "PowerPC (64 bit)", state.architecture = Some "ppc64";
+ "sparc", "SPARC (32 bit)", state.architecture = Some "sparc";
+ "sparc64", "SPARC (64 bit)", state.architecture = Some "sparc64";
+(* "auto", "Other or auto-detect",
+ state.architecture = None || state.architecture = Some "";*)
+ ]
+ with
+ | Yes (("auto"|"")::_ | []) -> Next { state with architecture = Some "" }
+ | Yes (arch :: _) -> Next { state with architecture = Some arch }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
+ let ask_memory state =
+ match
+ inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
+ 10 50
+ (Option.map_default string_of_int "" state.memory)
+ with
+ | Yes (""::_ | []) -> Next { state with memory = Some 0 }
+ | Yes (mem::_) ->
+ let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
+ if mem < 0 || (mem > 0 && mem < 64) then Ask_again
+ else Next { state with memory = Some mem }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
+ let ask_vcpus state =
+ match
+ inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
+ 10 50
+ (Option.map_default string_of_int "" state.vcpus)
+ with
+ | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
+ | Yes (vcpus::_) ->
+ let vcpus =
+ try int_of_string vcpus with Failure "int_of_string" -> -1 in
+ if vcpus < 0 then Ask_again
+ else Next { state with vcpus = Some vcpus }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
+ let ask_mac_address state =
+ match
+ inputbox "MAC address"
+ "Network MAC address. Leave blank to use a random address." 10 50
+ (Option.default "" state.mac_address)
+ with
+ | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
+ | Yes (mac :: _) -> Next { state with mac_address = Some mac }
+ | No | Help | Error -> Ask_again
+ | Back -> Prev
+ in
+
let ask_verify state =
match
yesno "Verify and proceed"
(sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
Connection: %s
-Remote host: %s
-Remote port: %s
+Host:port: %s : %s
Directory: %s
Network: %s
Send devices: %s
-Root (/) dev: %s"
+Root (/) dev: %s
+Hypervisor: %s
+Architecture: %s
+Memory: %s
+VCPUs: %s
+MAC address: %s"
(match state.transport with
- | Some Server -> "Server"
- | Some SSH -> "SSH" | Some TCP -> "TCP socket"
+ | Some Server -> "Server" | Some SSH -> "SSH"
| None -> "")
(Option.default "" state.remote_host)
(Option.default "" state.remote_port)
| Some Auto -> "Auto-configure" | Some Shell -> "Shell"
| None -> "")
(String.concat "," (Option.default [] state.devices_to_send))
- (Option.map_default dev_of_partition "" state.root_filesystem))
- 18 50
+ (Option.map_default dev_of_partition "" state.root_filesystem)
+ (match state.hypervisor with
+ | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
+ | None -> "Other / not set")
+ (match state.architecture with
+ | Some "" -> "Guess" | Some arch -> arch | None -> "")
+ (match state.memory with
+ | Some 0 -> "Same as physical"
+ | Some mem -> string_of_int mem ^ " MB" | None -> "")
+ (match state.vcpus with
+ | Some 0 -> "Same as physical"
+ | Some vcpus -> string_of_int vcpus | None -> "")
+ (match state.mac_address with
+ | Some "" -> "Random" | Some mac -> mac | None -> "")
+ )
+ 21 50
with
| Yes _ -> Next state
| Back -> Prev
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
|] in
in
let state = loop 0 defaults in
- eprintf "finished dialog loop\nfinal state = %s\n%!" (string_of_state state);
+ eprintf "finished dialog loop\n%!";
(* Check that the environment is a sane-looking live CD. If not, bail. *)
if is_dir "/mnt/root" <> Some true then
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";
- (* For Server and TCP type connections, we connect just once. *)
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 transport = Option.get state.transport in
- let sock =
+ (* Connect and disconnect from the remote system. *)
+ let do_connect, do_disconnect =
match transport with
- | Server | TCP ->
- let addrs =
- getaddrinfo remote_host remote_port [AI_SOCKTYPE SOCK_STREAM] in
- let rec loop = function
- | [] ->
- fail_dialog
- (sprintf "Unable to connect to %s:%s" remote_host remote_port)
- | addr :: addrs ->
- try
- let sock =
- socket addr.ai_family addr.ai_socktype addr.ai_protocol in
- connect sock addr.ai_addr;
- sock
- with Unix_error (err, syscall, extra) ->
- (* Log the error message, but continue around the loop. *)
- eprintf "%s:%s: %s\n%!" syscall extra (error_message err);
- loop addrs
- in
- loop addrs
+ | Server ->
+ let do_connect remote_name size =
+ let addrs =
+ getaddrinfo remote_host remote_port [AI_SOCKTYPE SOCK_STREAM] in
+ let rec loop = function
+ | [] ->
+ fail_dialog
+ (sprintf "Unable to connect to %s:%s" remote_host remote_port)
+ | addr :: addrs ->
+ try
+ let sock =
+ socket addr.ai_family addr.ai_socktype addr.ai_protocol in
+ connect sock addr.ai_addr;
+ let header = sprintf "p2v2 %s %Ld\n%!" remote_name size in
+ let len = String.length header in
+ assert (len = write sock header 0 len);
+ sock
+ with Unix_error (err, syscall, extra) ->
+ (* Log the error message, but continue around the loop. *)
+ eprintf "%s:%s: %s\n%!" syscall extra (error_message err);
+ loop addrs
+ in
+ loop addrs
+ in
+ let do_disconnect sock = close sock in
+ do_connect, do_disconnect
| SSH ->
- (* Just dummy socket for SSH for now ... *) stdin in
+ (* Cheat by keeping a private variable around containing the original
+ * channel, so we can close it easily. (XXX)
+ *)
+ let chan = ref None in
+ 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
+ let c = open_process_out cmd in
+ chan := Some c;
+ descr_of_out_channel c
+ in
+ let do_disconnect _ =
+ (match close_process_out (Option.get !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)
+ );
+ chan := None
+ in
+ do_connect, do_disconnect in
- (* Send the device snapshots to the remote host. *)
(* 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 hostname = safe_name (gethostname ()) in
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 "" | 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. *)
(* 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) ->
- let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
+ fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
eprintf "sending %s as %s\n%!" origin_dev remote_name;
let size =
(* Open the snapshot device. *)
let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
- (* Now connect (for SSH) or send the header (for Server/TCP). *)
- let sock, chan =
- match transport with
- | Server | TCP ->
- let header = sprintf "p2v2 %s %Ld\n%!" remote_name size in
- let len = String.length header in
- assert (len = write sock header 0 len);
- sock, Pervasives.stdout
- | SSH ->
- let cmd = sprintf "ssh -C -p %s %s \"cat > %s/%s\""
- (quote remote_port) (quote remote_host)
- (quote remote_directory) (quote remote_name) in
- let chan = open_process_out cmd in
- let fd = descr_of_out_channel chan in
- fd, chan in
+ (* Now connect. *)
+ let sock = do_connect remote_name size in
(* Copy the data. *)
let bufsize = 1024 * 1024 in
in
copy 0L start;
- (* For SSH disconnect, for Server/TCP send a newline. *)
- match transport with
- | Server | TCP ->
- ignore (write sock "\n" 0 1)
- | SSH ->
- 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)
+ (* Disconnect. *)
+ do_disconnect sock
) devices_to_send;
- (* Disconnect. *)
- (match transport with
- | Server | TCP -> close sock
- | SSH -> ()
- );
-
- (* XXX Write a configuration file. *)
- let conf_filename = basename ^ ".conf" in
-
(* 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\nvirsh define %s/%s\n\nWhen you press [OK] this machine will reboot."
- (Option.default "" state.remote_directory) conf_filename)
+ (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
);
git.annexia.org / virt-p2v.git / commitdiff