X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=virt-p2v.ml;h=7801a21eae07bc0e739f39674b99436a7824d1cc;hb=75afd7e7c6b3547e6d8d63b170589d807ae54316;hp=1640eede0c334854b2099d8aa6aa34ceec99d3b8;hpb=3bbcbfe8c8a210aab420a97e1b0d2c9d75b0fd39;p=virt-p2v.git diff --git a/virt-p2v.ml b/virt-p2v.ml index 1640eed..7801a21 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. @@ -37,11 +39,17 @@ type state = { greeting : bool; 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. @@ -60,8 +68,8 @@ let defaults = { *) 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; @@ -91,6 +99,31 @@ 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 ""' 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,23 +146,7 @@ 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 @@ -582,26 +599,21 @@ let rec main ttyname = (* 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 @@ -692,21 +704,106 @@ let rec main ttyname = | 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) @@ -715,8 +812,22 @@ 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 "" -> "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 @@ -745,6 +856,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,7 +891,7 @@ Root (/) dev: %s" 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 @@ -848,6 +969,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 +985,218 @@ 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 = + (* 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 "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",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 = 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 = @@ -914,21 +1209,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 = do_connect remote_name size in (* Copy the data. *) let bufsize = 1024 * 1024 in @@ -969,32 +1251,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 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 );