X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=virt-p2v.ml;h=23b59f0ad1e0d8c457354c28f1b137ca6e4695ef;hb=e3ee0ffbe935690a7caf6d2972d23af58650ae24;hp=1640eede0c334854b2099d8aa6aa34ceec99d3b8;hpb=3bbcbfe8c8a210aab420a97e1b0d2c9d75b0fd39;p=virt-p2v.git diff --git a/virt-p2v.ml b/virt-p2v.ml index 1640eed..23b59f0 100755 --- a/virt-p2v.ml +++ b/virt-p2v.ml @@ -4,6 +4,8 @@ #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. @@ -33,15 +35,21 @@ open ExtString type state = { greeting : bool; remote_host : string option; remote_port : string option; - transport : transport option; 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 : architecture option; + memory : int option; vcpus : int option; + mac_address : string option; + } 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 +and architecture = I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64 + | OtherArch of string | UnknownArch (*----------------------------------------------------------------------*) (* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section. @@ -60,19 +68,14 @@ let defaults = { *) greeting = true; - (* Transport: Set to 'Some Server' or 'Some SSH' or 'Some TCP' to - * assume Server, SSH or TCP transports respectively. - *) - transport = None; - (* Remote host and port. Set to 'Some "host"' and 'Some "port"', * else ask the user. *) remote_host = None; remote_port = None; - (* Remote directory (only for SSH transport). Set to 'Some "path"' - * to set up a directory path, else ask the user. + (* Remote directory. Set to 'Some "path"' to set up a + * directory path, else ask the user. *) remote_directory = None; @@ -91,6 +94,32 @@ let defaults = { * 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 UnknownArch' 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. *) (*----------------------------------------------------------------------*) @@ -113,30 +142,50 @@ let input_all_lines chan = 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 +let string_of_architecture = function + | I386 -> "i386" + | X86_64 -> "x86_64" + | IA64 -> "ia64" + | PPC -> "ppc" + | PPC64 -> "ppc64" + | SPARC -> "sparc" + | SPARC64 -> "sparc64" + | OtherArch arch -> arch + | UnknownArch -> "" + type dialog_status = Yes of string list | No | Help | Back | Error type ask_result = Next of state | Prev | Ask_again +type nature = LinuxSwap + | LinuxRoot of architecture * linux_distro + | WindowsRoot (* Windows C: *) + | LinuxBoot (* Linux /boot *) + | NotRoot (* mountable, but not / or /boot *) + | UnknownNature +and linux_distro = RHEL of int * int + | Fedora of int + | Debian of int * int + | OtherLinux + +let rec string_of_nature = function + | LinuxSwap -> "Linux swap" + | LinuxRoot (architecture, distro) -> + string_of_linux_distro distro ^ " " ^ string_of_architecture architecture + | WindowsRoot -> "Windows root" + | LinuxBoot -> "Linux /boot" + | NotRoot -> "Mountable non-root" + | UnknownNature -> "Unknown" +and string_of_linux_distro = function + | RHEL (a,b) -> sprintf "RHEL %d.%d" a b + | Fedora v -> sprintf "Fedora %d" v + | Debian (a,b) -> sprintf "Debian %d.%d" a b + | OtherLinux -> "Linux" + (* Dialog functions. * * Each function takes some common parameters (eg. ~title) and some @@ -276,9 +325,21 @@ let shget cmd = | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i) | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i) -(* Start an interactive shell. *) +(* Start an interactive shell. Need to juggle file descriptors a bit + * because bash write PS1 to stderr (currently directed to the logfile). + *) let shell () = - shfailok "PS1='\\u@\\h:\\w\\$ ' bash" + match fork () with + | 0 -> (* child, runs bash *) + close stderr; + dup2 stdout stderr; + (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *) + ignore ( + Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i" + ) + | _ -> (* parent, waits *) + eprintf "waiting for subshell to exit\n%!"; + ignore (wait ()) (* Some true if is dir/file, Some false if not, None if not found. *) let is_dir path = @@ -392,35 +453,46 @@ let snapshot = sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'" snapshot_dev sectors snapshot_dev ramdisk) -(* Try to perform automatic network configuration, assuming a Fedora or RHEL- - * like root filesystem mounted on /mnt/root. +(* Try to perform automatic network configuration, assuming a Fedora or + * RHEL-like root filesystem mounted on /mnt/root. *) let auto_network state = (* Fedora gives an error if this file doesn't exist. *) sh "touch /etc/resolv.conf"; - chdir "/etc/sysconfig"; - - sh "mv network network.saved"; - sh "mv networking networking.saved"; - sh "mv network-scripts network-scripts.saved"; - - (* Originally I symlinked these, but that causes dhclient to - * keep open /mnt/root (as its cwd is in network-scripts subdir). - * So now we will copy them recursively instead. +(* + (* 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. *) - sh "cp -r /mnt/root/etc/sysconfig/network ."; - sh "cp -r /mnt/root/etc/sysconfig/networking ."; - sh "cp -r /mnt/root/etc/sysconfig/network-scripts ."; - + 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 + * directory open on /etc/sysconfig/network-scripts/ + *) + sh "mount -o bind /mnt/root/etc /etc"; let status = shwithstatus "/etc/init.d/network start" in - - sh "rm -rf network networking network-scripts"; - sh "mv network.saved network"; - sh "mv networking.saved networking"; - sh "mv network-scripts.saved network-scripts"; - - chdir "/tmp"; + sh "umount -l /etc"; (* Try to ping the remote host to see if this worked. *) shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host); @@ -514,6 +586,13 @@ let rec main ttyname = close fd); printf "virt-p2v.ml starting up ...\n%!"; + (* Check that the environment is a sane-looking live CD. If not, bail. *) + if is_dir "/mnt/root" <> Some true then + fail_dialog + "You should only run this script from the live CD or a USB key."; + + printf "virt-p2v.ml detecting hard drives (this may take some time) ...\n%!"; + (* Search for all non-removable block devices. Do this early and bail * if we can't find anything. This is a list of strings, like "hda". *) @@ -580,32 +659,141 @@ let rec main ttyname = (* Concatenate LVs & Parts *) lvs @ parts in + (* Try to determine the nature of each partition. + * Root? Swap? Architecture? etc. + *) + let all_partitions : (partition * nature) list = + (* Output of 'file' command for Linux swap file. *) + let swap = Pcre.regexp "Linux.*swap.*file" in + (* Contents of /etc/redhat-release. *) + let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in + let fedora = Pcre.regexp "Fedora.*release (\\d+)" in + (* Contents of /etc/debian_version. *) + let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in + (* Output of 'file' on certain executables. *) + let i386 = Pcre.regexp ", Intel 80386," in + let x86_64 = Pcre.regexp ", x86-64," in + let itanic = Pcre.regexp ", IA-64," in + + (* Examine the filesystem mounted on 'mnt' to determine the + * operating system, and, if Linux, the distro. + *) + let detect_os mnt = + if is_dir (mnt ^ "/Windows") = Some true && + is_file (mnt ^ "/autoexec.bat") = Some true then + WindowsRoot + else if is_dir (mnt ^ "/etc") = Some true && + is_dir (mnt ^ "/sbin") = Some true && + is_dir (mnt ^ "/var") = Some true then ( + if is_file (mnt ^ "/etc/redhat-release") = Some true then ( + let chan = open_in (mnt ^ "/etc/redhat-release") in + let lines = input_all_lines chan in + close_in chan; + + match lines with + | [] -> (* empty /etc/redhat-release ...? *) + LinuxRoot (UnknownArch, OtherLinux) + | line::_ -> (* try to detect OS from /etc/redhat-release *) + try + let subs = Pcre.exec ~rex:rhel line in + let major = int_of_string (Pcre.get_substring subs 1) in + let minor = + try int_of_string (Pcre.get_substring subs 2) + with Not_found -> 0 in + LinuxRoot (UnknownArch, RHEL (major, minor)) + with + Not_found | Failure "int_of_string" -> + try + let subs = Pcre.exec ~rex:fedora line in + let version = int_of_string (Pcre.get_substring subs 1) in + LinuxRoot (UnknownArch, Fedora version) + with + Not_found | Failure "int_of_string" -> + LinuxRoot (UnknownArch, OtherLinux) + ) + else if is_file (mnt ^ "/etc/debian_version") = Some true then ( + let chan = open_in (mnt ^ "/etc/debian_version") in + let lines = input_all_lines chan in + close_in chan; + + match lines with + | [] -> (* empty /etc/debian_version ...? *) + LinuxRoot (UnknownArch, OtherLinux) + | line::_ -> (* try to detect version from /etc/debian_version *) + try + let subs = Pcre.exec ~rex:debian line in + let major = int_of_string (Pcre.get_substring subs 1) in + let minor = int_of_string (Pcre.get_substring subs 2) in + LinuxRoot (UnknownArch, Debian (major, minor)) + with + Not_found | Failure "int_of_string" -> + LinuxRoot (UnknownArch, OtherLinux) + ) + else + LinuxRoot (UnknownArch, OtherLinux) + ) else if is_dir (mnt ^ "/grub") = Some true && + is_file (mnt ^ "/grub/stage1") = Some true then ( + LinuxBoot + ) else + NotRoot (* mountable, but not a root filesystem *) + in + + (* Examine the Linux root filesystem mounted on 'mnt' to + * determine the architecture. We do this by looking at some + * well-known binaries that we expect to be there. + *) + let detect_architecture mnt = + let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in + match shget cmd with + | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386 + | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64 + | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64 + | _ -> UnknownArch + in + + List.map ( + fun part -> + let dev = dev_of_partition part in (* Get /dev device. *) + + let nature = + (* Use 'file' command to detect if it is swap. *) + let cmd = "file -sbL " ^ quote dev in + match shget cmd with + | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap + | _ -> + (* Blindly try to mount the device. *) + let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in + match shwithstatus cmd with + | 0 -> + let os = detect_os "/mnt/root" in + let nature = + match os with + | LinuxRoot (UnknownArch, distro) -> + let architecture = detect_architecture "/mnt/root" in + LinuxRoot (architecture, distro) + | os -> os in + sh "umount /mnt/root"; + nature + + | _ -> UnknownNature (* not mountable *) + + in + + eprintf "partition detection: %s is %s\n%!" + dev (string_of_nature nature); + + (part, nature) + ) all_partitions + in + + printf "virt-p2v.ml finished detecting hard drives\n%!"; + (* 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 - ] - 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 _ | No | Help | Error -> Ask_again - | Back -> Prev - in - let ask_hostname state = match inputbox "Remote host" "Remote host" 10 50 @@ -620,25 +808,21 @@ let rec main ttyname = let ask_port state = match inputbox "Remote port" "Remote port" 10 50 - (Option.default "" state.remote_port) + (Option.default "22" state.remote_port) with - | Yes [] -> - (match state.transport with - | Some SSH -> Next { state with remote_port = Some "22" } - | _ -> Next { state with remote_port = Some "16211" } - ) + | Yes ([]|""::_) -> Next { state with remote_port = Some "22" } | Yes (port::_) -> Next { state with remote_port = Some port } | No | Help | Error -> Ask_again | Back -> Prev in let ask_directory state = + let default_dir = "/var/lib/xen/images" in match inputbox "Remote directory" "Remote directory" 10 50 - (Option.default "" state.remote_directory) + (Option.default default_dir state.remote_directory) with - | Yes [] -> - Next { state with remote_directory = Some "/var/lib/xen/images" } + | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir } | Yes (dir::_) -> Next { state with remote_directory = Some dir } | No | Help | Error -> Ask_again | Back -> Prev @@ -676,38 +860,137 @@ let rec main ttyname = let ask_root state = let parts = List.mapi ( - fun i part -> - (string_of_int i, dev_of_partition part, + fun i (part, nature) -> + let descr = + match nature with + | LinuxSwap -> " (Linux swap)" + | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b + | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v + | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b + | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)" + | WindowsRoot -> " (Windows C:)" + | LinuxBoot -> " (Linux /boot)" + | NotRoot -> " (filesystem)" + | UnknownNature -> "" in + (string_of_int i, + dev_of_partition part ^ descr, Some part = state.root_filesystem) ) all_partitions in match radiolist "Root device" - "Pick partition containing the root (/) filesystem" 15 50 6 + "Pick partition containing the root (/) filesystem" 18 70 9 parts with | Yes (i::_) -> - let part = List.nth all_partitions (int_of_string i) in + let (part, _) = List.nth all_partitions (int_of_string i) in Next { state with root_filesystem = Some part } | Yes [] | No | Help | Error -> Ask_again | 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", "Auto-detect", + state.architecture = None || state.architecture = Some UnknownArch; + ] + with + | Yes ("i386" :: _) -> Next { state with architecture = Some I386 } + | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 } + | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 } + | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC } + | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 } + | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC } + | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 } + | Yes _ -> Next { state with architecture = Some UnknownArch } + | 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" - (match state.transport with - | Some Server -> "Server" - | Some SSH -> "SSH" | Some TCP -> "TCP socket" - | None -> "") +Root (/) dev: %s +Hypervisor: %s +Architecture: %s +Memory: %s +VCPUs: %s +MAC address: %s" (Option.default "" state.remote_host) (Option.default "" state.remote_port) (Option.default "" state.remote_directory) @@ -715,8 +998,23 @@ Root (/) dev: %s" | 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 UnknownArch -> "Auto-detect" + | Some arch -> string_of_architecture 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 @@ -731,8 +1029,6 @@ Root (/) dev: %s" let dlgs = [| ask_greeting, (* Initial greeting. *) defaults.greeting; - ask_transport, (* Transport (ssh, tcp) *) - defaults.transport = None; ask_hostname, (* Hostname. *) defaults.remote_host = None; ask_port, (* Port number. *) @@ -745,6 +1041,16 @@ Root (/) dev: %s" 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 @@ -770,11 +1076,7 @@ Root (/) dev: %s" in let state = loop 0 defaults in - eprintf "finished dialog loop\nfinal state = %s\n%!" (string_of_state state); - - (* Check that the environment is a sane-looking live CD. If not, bail. *) - if is_dir "/mnt/root" <> Some true then - fail_dialog "You should only run this script from the live CD or a USB key."; + eprintf "finished dialog loop\n%!"; (* Switch LVM config. *) sh "vgchange -a n"; @@ -848,6 +1150,15 @@ Root (/) dev: %s" 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. *) @@ -855,53 +1166,183 @@ Root (/) dev: %s" (* 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 = - 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 - | SSH -> - (* Just dummy socket for SSH for now ... *) stdin in - (* Send the device snapshots to the remote host. *) + (* 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 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 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 "value". *) + 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 + + (* 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 . *) + 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) -> - 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 = @@ -914,21 +1355,8 @@ Root (/) dev: %s" (* 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,_) as conn = do_connect remote_name size in (* Copy the data. *) let bufsize = 1024 * 1024 in @@ -969,32 +1397,15 @@ Root (/) dev: %s" 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 conn ) 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 );