Include <uuid> and <maxmem> (required for Xen hypervisor).
[virt-p2v.git] / virt-p2v
1 #!/usr/bin/ocamlrun /usr/bin/ocaml
2 (* -*- tuareg -*- *)
3 (* virt-p2v is a script which performs a physical to
4  * virtual conversion of local disks.
5  *
6  * Copyright (C) 2007-2008 Red Hat Inc.
7  * Written by Richard W.M. Jones <rjones@redhat.com>
8  *
9  * This program is free software; you can redistribute it and/or modify
10  * it under the terms of the GNU General Public License as published by
11  * the Free Software Foundation; either version 2 of the License, or
12  * (at your option) any later version.
13  *
14  * This program is distributed in the hope that it will be useful,
15  * but WITHOUT ANY WARRANTY; without even the implied warranty of
16  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17  * GNU General Public License for more details.
18  *
19  * You should have received a copy of the GNU General Public License
20  * along with this program; if not, write to the Free Software
21  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
22  *)
23
24 #load "unix.cma";;
25 #directory "+extlib";;
26 #load "extLib.cma";;
27 #directory "+pcre";;
28 #load "pcre.cma";;
29 #directory "+xml-light";;
30 #load "xml-light.cma";;
31
32 open Unix
33 open Printf
34 open ExtList
35 open ExtString
36
37 type state = { greeting : bool;
38                remote_host : string option; remote_port : string option;
39                remote_directory : string option;
40                remote_username : string option;
41                network : network option;
42                static_network_config : static_network_config option;
43                devices_to_send : string list option;
44                root_filesystem : partition option;
45                hypervisor : hypervisor option;
46                architecture : architecture option;
47                memory : int option; vcpus : int option;
48                mac_address : string option;
49              }
50 and network = Auto
51             | Shell
52             | QEMUUserNet
53             | Static
54 and partition = Part of string * string (* eg. "hda", "1" *)
55               | LV of string * string   (* eg. "VolGroup00", "LogVol00" *)
56 and hypervisor = Xen | QEMU | KVM
57 and architecture = I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
58                  | OtherArch of string | UnknownArch
59 and static_network_config = string * string * string * string * string
60     (* interface, address, netmask, gateway, nameserver *)
61
62 (*----------------------------------------------------------------------*)
63 (* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
64  *
65  * If left as they are, then this will create a generic virt-p2v script
66  * which asks the user for each question.  If you set the defaults here
67  * then you will get a custom virt-p2v which is partially or even fully
68  * automated and won't ask the user any questions.
69  *
70  * Note that 'None' means 'no default' (ie. ask the user) whereas
71  * 'Some foo' means use 'foo' as the answer.
72  *)
73 let defaults = {
74   (* If greeting is true, wait for keypress after boot and during
75    * final verification.  Set to 'false' for less interactions.
76    *)
77   greeting = true;
78
79   (* These are now documented in the man page virt-p2v(1).
80    * 'None' means ask the user.
81    * After changing them, run './virt-p2v --test' to check syntax.
82    *)
83   remote_host = None;
84   remote_port = None;
85   remote_directory = None;
86   remote_username = None;
87   devices_to_send = None;
88   root_filesystem = None;
89   network = None;
90   static_network_config = None;
91   hypervisor = None;
92   architecture = None;
93   memory = None;
94   vcpus = None;
95   mac_address = None;
96 }
97 (* END OF CUSTOM virt-p2v SCRIPT SECTION.                               *)
98 (*----------------------------------------------------------------------*)
99
100 (* General helper functions. *)
101
102 let sort_uniq ?(cmp = compare) xs =     (* sort and uniq a list *)
103   let xs = List.sort ~cmp xs in
104   let rec loop = function
105     | [] -> [] | [x] -> [x]
106     | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
107     | x :: xs -> x :: loop xs
108   in
109   loop xs
110
111 let input_all_lines chan =
112   let lines = ref [] in
113   try
114     while true do lines := input_line chan :: !lines done; []
115   with
116     End_of_file -> List.rev !lines
117
118 let dev_of_partition = function
119   | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
120   | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
121
122 let string_of_architecture = function
123   | I386 -> "i386"
124   | X86_64 -> "x86_64"
125   | IA64 -> "ia64"
126   | PPC -> "ppc"
127   | PPC64 -> "ppc64"
128   | SPARC -> "sparc"
129   | SPARC64 -> "sparc64"
130   | OtherArch arch -> arch
131   | UnknownArch -> ""
132
133 type dialog_status = Yes of string list | No | Help | Back | Error
134
135 type ask_result = Next of state | Prev | Ask_again
136
137 type nature = LinuxSwap
138             | LinuxRoot of architecture * linux_distro
139             | WindowsRoot               (* Windows C: *)
140             | LinuxBoot                 (* Linux /boot *)
141             | NotRoot                   (* mountable, but not / or /boot *)
142             | UnknownNature
143 and linux_distro = RHEL of int * int
144                  | Fedora of int
145                  | Debian of int * int
146                  | OtherLinux
147
148 let rec string_of_nature = function
149   | LinuxSwap -> "Linux swap"
150   | LinuxRoot (architecture, distro) ->
151       string_of_linux_distro distro ^ " " ^ string_of_architecture architecture
152   | WindowsRoot -> "Windows root"
153   | LinuxBoot -> "Linux /boot"
154   | NotRoot -> "Mountable non-root"
155   | UnknownNature -> "Unknown"
156 and string_of_linux_distro = function
157   | RHEL (a,b) -> sprintf "RHEL %d.%d" a b
158   | Fedora v -> sprintf "Fedora %d" v
159   | Debian (a,b) -> sprintf "Debian %d.%d" a b
160   | OtherLinux -> "Linux"
161
162 (* Dialog functions.
163  *
164  * Each function takes some common parameters (eg. ~title) and some
165  * dialog-specific parameters.
166  *
167  * Returns the exit status (Yes lines | No | Help | Back | Error).
168  *)
169 let msgbox, yesno, inputbox, radiolist, checklist, form =
170   (* Internal function to actually run the "dialog" shell command. *)
171   let run_dialog cparams params =
172     let params = cparams @ params in
173     eprintf "dialog %s\n%!"
174       (String.concat " " (List.map (sprintf "%S") params));
175
176     (* 'dialog' writes its output/result to stderr, so we need to take
177      * special steps to capture that - in other words, manual pipe/fork.
178      *)
179     let rfd, wfd = pipe () in
180     match fork () with
181     | 0 ->                              (* child, runs dialog *)
182         close rfd;
183         dup2 wfd stderr;                (* capture stderr to pipe *)
184         execvp "dialog" (Array.of_list ("dialog" :: params))
185     | pid ->                            (* parent *)
186         close wfd;
187         let chan = in_channel_of_descr rfd in
188         let result = input_all_lines chan in
189         close rfd;
190         eprintf "dialog result: %S\n%!" (String.concat "\n" result);
191         match snd (wait ()) with
192         | WEXITED 0 -> Yes result       (* something selected / entered *)
193         | WEXITED 1 -> No               (* cancel / no button *)
194         | WEXITED 2 -> Help             (* help pressed *)
195         | WEXITED 3 -> Back             (* back button *)
196         | WEXITED _ -> Error            (* error or Esc *)
197         | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
198         | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
199   in
200
201   (* Handle the common parameters.  Note Continuation Passing Style. *)
202   let with_common cont ?(cancel=false) ?(backbutton=true) title =
203     let params = ["--title"; title] in
204     let params = if not cancel then "--nocancel" :: params else params in
205     let params =
206       if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
207       else params in
208     cont params
209   in
210
211   (* Message box and yes/no box. *)
212   let rec msgbox =
213     with_common (
214       fun cparams text height width ->
215         run_dialog cparams
216           [ "--msgbox"; text; string_of_int height; string_of_int width ]
217     )
218   and yesno =
219     with_common (
220       fun cparams text height width ->
221         run_dialog cparams
222           [ "--yesno"; text; string_of_int height; string_of_int width ]
223     )
224
225   (* Simple input box. *)
226   and inputbox =
227     with_common (
228       fun cparams text height width default ->
229         run_dialog cparams
230           [ "--inputbox"; text; string_of_int height; string_of_int width;
231             default ]
232     )
233
234   (* Radio list and check list. *)
235   and radiolist =
236     with_common (
237       fun cparams text height width listheight items ->
238         let items = List.map (
239           function
240           | tag, item, true -> [ tag; item; "on" ]
241           | tag, item, false -> [ tag; item; "off" ]
242         ) items in
243         let items = List.concat items in
244         let items = "--single-quoted" ::
245           "--radiolist" :: text ::
246           string_of_int height :: string_of_int width ::
247           string_of_int listheight :: items in
248         run_dialog cparams items
249     )
250   and checklist =
251     with_common (
252       fun cparams text height width listheight items ->
253         let items = List.map (
254           function
255           | tag, item, true -> [ tag; item; "on" ]
256           | tag, item, false -> [ tag; item; "off" ]
257         ) items in
258         let items = List.concat items in
259         let items = "--separate-output" ::
260           "--checklist" :: text ::
261           string_of_int height :: string_of_int width ::
262           string_of_int listheight :: items in
263         run_dialog cparams items
264     )
265
266   (* Form. *)
267   and form =
268     with_common (
269       fun cparams text height width formheight items ->
270         let items = List.map (
271           fun (label, y, x, item, y', x', flen, ilen) ->
272             [ label; string_of_int y; string_of_int x; item;
273               string_of_int y'; string_of_int x';
274               string_of_int flen; string_of_int ilen ]
275         ) items in
276         let items = List.concat items in
277         let items = "--form" :: text ::
278           string_of_int height :: string_of_int width ::
279           string_of_int formheight :: items in
280         run_dialog cparams items
281     )
282   in
283   msgbox, yesno, inputbox, radiolist, checklist, form
284
285 (* Print failure dialog and exit. *)
286 let fail_dialog text =
287   let text = "\n" ^ text ^ "\n\nIf you want to report this error, there is a shell on [ALT] [F2], log in as root with no password.\n\nPlease provide the contents of /tmp/virt-p2v.log and output of the 'dmesg' command." in
288   ignore (msgbox "Error" text 17 50);
289   exit 1
290
291 (* Shell-safe quoting function.  In fact there's one in stdlib so use it. *)
292 let quote = Filename.quote
293
294 (* Run a shell command and check it returns 0. *)
295 let sh cmd =
296   eprintf "sh: %s\n%!" cmd;
297   if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
298
299 let shfailok cmd =
300   eprintf "shfailok: %s\n%!" cmd;
301   ignore (Sys.command cmd)
302
303 let shwithstatus cmd =
304   eprintf "shwithstatus: %s\n%!" cmd;
305   Sys.command cmd
306
307 (* Same as `cmd` in shell.  Any error message will be in the logfile. *)
308 let shget cmd =
309   eprintf "shget: %s\n%!" cmd;
310   let chan = open_process_in cmd in
311   let lines = input_all_lines chan in
312   match close_process_in chan with
313   | WEXITED 0 -> Some lines             (* command succeeded *)
314   | WEXITED _ -> None                   (* command failed *)
315   | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
316   | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
317
318 (* Start an interactive shell.  Need to juggle file descriptors a bit
319  * because bash write PS1 to stderr (currently directed to the logfile).
320  *)
321 let shell () =
322   match fork () with
323   | 0 ->                                (* child, runs bash *)
324       close stderr;
325       dup2 stdout stderr;
326       (* Sys.command runs 'sh -c' which blows away PS1, so set it late. *)
327       ignore (
328         Sys.command "PS1='\\u@\\h:\\w\\$ ' /bin/bash --norc --noprofile -i"
329       )
330   | _ ->                                (* parent, waits *)
331       eprintf "waiting for subshell to exit\n%!";
332       ignore (wait ())
333
334 (* Some true if is dir/file, Some false if not, None if not found. *)
335 let is_dir path =
336   try Some ((stat path).st_kind = S_DIR)
337   with Unix_error (ENOENT, "stat", _) -> None
338 let is_file path =
339   try Some ((stat path).st_kind = S_REG)
340   with Unix_error (ENOENT, "stat", _) -> None
341
342 (* Useful regular expression. *)
343 let whitespace = Pcre.regexp "[ \t]+"
344
345 (* Generate a predictable safe name containing only letters, numbers
346  * and underscores.  If passed a string with no letters or numbers,
347  * generates "_1", "_2", etc.
348  *)
349 let safe_name =
350   let next_anon =
351     let i = ref 0 in
352     fun () -> incr i; "_" ^ string_of_int !i
353   in
354   fun name ->
355     let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
356     let name = String.copy name in
357     let have_safe = ref false in
358     for i = 0 to String.length name - 1 do
359       if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
360     done;
361     if !have_safe then name else next_anon ()
362
363 type block_device = string * int64      (* "hda" & size in bytes *)
364
365 (* Parse the output of 'lvs' to get list of LV names, sizes,
366  * corresponding PVs, etc.  Returns a list of (lvname, PVs, lvsize).
367  *)
368 let get_lvs =
369   let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
370
371   function () ->
372     match
373     shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
374     with
375     | None -> []
376     | Some lines ->
377         let lines = List.map (Pcre.split ~rex:whitespace) lines in
378         List.map (
379           function
380           | [vg; lv; pvs; lvsize]
381           | [_; vg; lv; pvs; lvsize] ->
382               let pvs = String.nsplit pvs "," in
383               let pvs = List.filter_map (
384                 fun pv ->
385                   try
386                     let subs = Pcre.exec ~rex:devname pv in
387                     Some (Pcre.get_substring subs 1)
388                   with
389                     Not_found ->
390                       eprintf "lvs: unexpected device name: %s\n%!" pv;
391                       None
392               ) pvs in
393               LV (vg, lv), pvs, lvsize
394           | line ->
395               failwith ("lvs: unexpected output: " ^ String.concat "," line)
396         ) lines
397
398 (* Get the partitions on a block device.
399  * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
400  *)
401 let get_partitions dev =
402   let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
403   let devdir = "/sys/block/" ^ dev in
404   let parts = Sys.readdir devdir in
405   let parts = Array.to_list parts in
406   let parts = List.filter (
407     fun name -> Some true = is_dir (devdir ^ "/" ^ name)
408   ) parts in
409   let parts = List.filter_map (
410     fun part ->
411       try
412         let subs = Pcre.exec ~rex part in
413         Some (Part (dev, Pcre.get_substring subs 1))
414       with
415         Not_found -> None
416   ) parts in
417   parts
418
419 (* Generate snapshot device name from device name. *)
420 let snapshot_name dev =
421   "snap" ^ (safe_name dev)
422
423 (* Perform a device-mapper snapshot with ramdisk overlay. *)
424 let snapshot =
425   let next_free_ram_disk =
426     let i = ref 0 in
427     fun () -> incr i; "/dev/ram" ^ string_of_int !i
428   in
429   fun origin_dev snapshot_dev ->
430     let ramdisk = next_free_ram_disk () in
431     let sectors =
432       let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
433       let lines = shget cmd in
434       match lines with
435       | Some (sectors::_) -> Int64.of_string sectors
436       | Some [] | None ->
437           fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
438
439     (* Create the snapshot origin device.  Called, eg. snap_sda1_org *)
440     sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
441           snapshot_dev sectors origin_dev);
442     (* Create the snapshot. *)
443     sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
444           snapshot_dev sectors snapshot_dev ramdisk)
445
446 (* Try to perform automatic network configuration, assuming a Fedora or
447  * RHEL-like root filesystem mounted on /mnt/root.
448  *)
449 let auto_network state =
450   (* Fedora gives an error if this file doesn't exist. *)
451   sh "touch /etc/resolv.conf";
452
453 (*
454   (* We can run /mnt/root/etc/init.d/network in a chroot environment,
455    * however this won't work directly because the architecture of the
456    * binaries under /mnt/root (eg. /mnt/root/sbin/ip) might not match
457    * the architecture of the live CD kernel.  In particular, a 32 bit
458    * live CD cannot run 64 bit binaries.  So we also have to bind-mount
459    * the live CD's /bin, /sbin, /lib etc. over the equivalents in
460    * /mnt/root.
461    *)
462   let bind dir =
463     if is_dir dir = Some true then
464       sh ("mount -o bind " ^ quote dir ^ " " ^ quote ("/mnt/root" ^ dir))
465   in
466   let unbind dir =
467     if is_dir dir = Some true then sh ("umount -l " ^ quote ("/mnt/root" ^ dir))
468   in
469   let dirs = [
470     "/bin"; "/sbin"; "/lib"; "/lib64";
471     "/usr/bin"; "/usr/sbin"; "/usr/lib"; "/usr/lib64";
472     "/proc"; "/sys"
473   ] in
474   List.iter bind dirs;
475   let status = shwithstatus "chroot /mnt/root /etc/init.d/network start" in
476   List.iter unbind dirs;
477 *)
478
479   (* Simpler way to do the above.
480    * NB. Lazy unmount is required because dhclient keeps its current
481    * directory open on /etc/sysconfig/network-scripts/
482    *)
483   sh "mount -o bind /mnt/root/etc /etc";
484   let status = shwithstatus "/etc/init.d/network start" in
485   sh "umount -l /etc";
486
487   (* Try to ping the remote host to see if this worked. *)
488   shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
489
490   if state.greeting then (
491     printf "\n\nDid automatic network configuration work?\n";
492     printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
493     printf "    (y/n) %!";
494     let line = read_line () in
495     String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
496   )
497   else
498     (* Non-interactive: return the status of /etc/init.d/network start. *)
499     status = 0
500
501 (* Configure the network statically. *)
502 let static_network state =
503   match state.static_network_config with
504   | None -> false                       (* failed *)
505   | Some (interface, address, netmask, gateway, nameserver) ->
506       let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
507       try
508         do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
509                           (quote interface) (quote address) (quote netmask));
510         do_cmd_or_exit (sprintf "route add default gw %s %s"
511                           (quote gateway) (quote interface));
512         if nameserver <> "" then
513           do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
514                             (quote nameserver));
515         true                            (* succeeded *)
516       with
517         Exit -> false                   (* failed *)
518
519 let qemu_network () =
520   sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0";
521   sh "route add default gw 10.0.2.2 eth0";
522   sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"
523
524 (* Map local device names to remote devices names.  At the moment we
525  * just change sd* to hd* (as device names appear under fullvirt).  In
526  * future, lots of complex possibilities.
527  *)
528 let remote_of_origin_dev =
529   let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
530   let devsd_subst = Pcre.subst "hd$1" in
531   fun dev ->
532     Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
533
534 (* Rewrite /mnt/root/etc/fstab. *)
535 let rewrite_fstab state devices_to_send =
536   let filename = "/mnt/root/etc/fstab" in
537   if is_file filename = Some true then (
538     sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
539
540     let chan = open_in filename in
541     let lines = input_all_lines chan in
542     close_in chan;
543     let lines = List.map (Pcre.split ~rex:whitespace) lines in
544     let lines = List.map (
545       function
546       | dev :: rest when String.starts_with dev "/dev/" ->
547           let dev = String.sub dev 5 (String.length dev - 5) in
548           let dev = remote_of_origin_dev dev in
549           let dev = "/dev/" ^ dev in
550           dev :: rest
551       | line -> line
552     ) lines in
553
554     let chan = open_out filename in
555     List.iter (
556       function
557       | [dev; mountpoint; fstype; options; freq; passno] ->
558           fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
559             dev mountpoint fstype options freq passno
560       | line ->
561           output_string chan (String.concat " " line)
562     ) lines;
563     close_out chan
564   )
565
566 let () = Random.self_init ()
567
568 let random_mac_address () =
569   let random =
570     List.map (sprintf "%02x") (
571       List.map (fun _ -> Random.int 256) [0;0;0]
572     ) in
573   String.concat ":" ("00"::"16"::"3e"::random)
574
575 let random_uuid =
576   let hex = "0123456789abcdef" in
577   fun () ->
578   let str = String.create 32 in
579   for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
580   str
581
582 (* Main entry point. *)
583 let rec main ttyname =
584   (* Running from an init script.  We don't have much of a
585    * login environment, so set one up.
586    *)
587   putenv "PATH"
588     (String.concat ":"
589        ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
590         "/usr/bin"; "/bin"]);
591   putenv "HOME" "/root";
592   putenv "LOGNAME" "root";
593
594   (* We can safely write in /tmp (it's a synthetic live CD directory). *)
595   chdir "/tmp";
596
597   (* Set up logging to /tmp/virt-p2v.log. *)
598   let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
599   dup2 fd stderr;
600   close fd;
601
602   (* Log the start up time. *)
603   eprintf "\n\n**************************************************\n\n";
604   let tm = localtime (time ()) in
605   eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
606     (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
607
608   (* Connect stdin/stdout to the tty. *)
609   (match ttyname with
610    | None -> ()
611    | Some ttyname ->
612        let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
613        dup2 fd stdin;
614        dup2 fd stdout;
615        close fd);
616   printf "virt-p2v starting up ...\n%!";
617
618   (* Disable screen blanking on tty. *)
619   sh "setterm -blank 0";
620
621   (* Check that the environment is a sane-looking live CD.  If not, bail. *)
622   if is_dir "/mnt/root" <> Some true then
623     fail_dialog
624       "You should only run this script from the live CD or a USB key.";
625
626   printf "virt-p2v detecting hard drives (this may take some time) ...\n%!";
627
628   (* Search for all non-removable block devices.  Do this early and bail
629    * if we can't find anything.  This is a list of strings, like "hda".
630    *)
631   let all_block_devices : block_device list =
632     let rex = Pcre.regexp "^[hs]d" in
633     let devices = Array.to_list (Sys.readdir "/sys/block") in
634     let devices = List.sort devices in
635     let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
636     eprintf "all_block_devices: block devices: %s\n%!"
637       (String.concat "; " devices);
638     (* Run blockdev --getsize64 on each, and reject any where this fails
639      * (probably removable devices).
640      *)
641     let devices = List.filter_map (
642       fun d ->
643         let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
644         let lines = shget cmd in
645         match lines with
646         | Some (blksize::_) -> Some (d, Int64.of_string blksize)
647         | Some [] | None -> None
648     ) devices in
649     eprintf "all_block_devices: non-removable block devices: %s\n%!"
650       (String.concat "; "
651          (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
652     if devices = [] then
653       fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
654     devices in
655
656   (* Search for partitions and LVs (anything that could contain a
657    * filesystem directly).  We refer to these generically as
658    * "partitions".
659    *)
660   let all_partitions : partition list =
661     (* LVs & PVs. *)
662     let lvs, pvs =
663       let lvs = get_lvs () in
664       let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
665       let pvs = List.concat pvs in
666       let pvs = sort_uniq pvs in
667       eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
668       let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
669       eprintf "all_partitions: LVs: %s\n%!"
670         (String.concat "; " (List.map dev_of_partition lvs));
671       lvs, pvs in
672
673     (* Partitions (eg. "sda1", "sda2"). *)
674     let parts =
675       let parts = List.map fst all_block_devices in
676       let parts = List.map get_partitions parts in
677       let parts = List.concat parts in
678       eprintf "all_partitions: all partitions: %s\n%!"
679         (String.concat "; " (List.map dev_of_partition parts));
680
681       (* Remove any partitions which are PVs. *)
682       let parts = List.filter (
683         function
684         | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
685         | LV _ -> assert false
686       ) parts in
687       parts in
688     eprintf "all_partitions: partitions after removing PVs: %s\n%!"
689       (String.concat "; " (List.map dev_of_partition parts));
690
691     (* Concatenate LVs & Parts *)
692     lvs @ parts in
693
694   (* Try to determine the nature of each partition.
695    * Root? Swap? Architecture? etc.
696    *)
697   let all_partitions : (partition * nature) list =
698     (* Output of 'file' command for Linux swap file. *)
699     let swap = Pcre.regexp "Linux.*swap.*file" in
700     (* Contents of /etc/redhat-release. *)
701     let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
702     let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
703     (* Contents of /etc/debian_version. *)
704     let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
705     (* Output of 'file' on certain executables. *)
706     let i386 = Pcre.regexp ", Intel 80386," in
707     let x86_64 = Pcre.regexp ", x86-64," in
708     let itanic = Pcre.regexp ", IA-64," in
709
710     (* Examine the filesystem mounted on 'mnt' to determine the
711      * operating system, and, if Linux, the distro.
712      *)
713     let detect_os mnt =
714       if is_dir (mnt ^ "/Windows") = Some true &&
715         is_file (mnt ^ "/autoexec.bat") = Some true then
716           WindowsRoot
717       else if is_dir (mnt ^ "/etc") = Some true &&
718         is_dir (mnt ^ "/sbin") = Some true &&
719         is_dir (mnt ^ "/var") = Some true then (
720           if is_file (mnt ^ "/etc/redhat-release") = Some true then (
721             let chan = open_in (mnt ^ "/etc/redhat-release") in
722             let lines = input_all_lines chan in
723             close_in chan;
724
725             match lines with
726             | [] -> (* empty /etc/redhat-release ...? *)
727                 LinuxRoot (UnknownArch, OtherLinux)
728             | line::_ -> (* try to detect OS from /etc/redhat-release *)
729                 try
730                   let subs = Pcre.exec ~rex:rhel line in
731                   let major = int_of_string (Pcre.get_substring subs 1) in
732                   let minor =
733                     try int_of_string (Pcre.get_substring subs 2)
734                     with Not_found -> 0 in
735                   LinuxRoot (UnknownArch, RHEL (major, minor))
736                 with
737                   Not_found | Failure "int_of_string" ->
738                     try
739                       let subs = Pcre.exec ~rex:fedora line in
740                       let version = int_of_string (Pcre.get_substring subs 1) in
741                       LinuxRoot (UnknownArch, Fedora version)
742                     with
743                       Not_found | Failure "int_of_string" ->
744                         LinuxRoot (UnknownArch, OtherLinux)
745           )
746           else if is_file (mnt ^ "/etc/debian_version") = Some true then (
747             let chan = open_in (mnt ^ "/etc/debian_version") in
748             let lines = input_all_lines chan in
749             close_in chan;
750
751             match lines with
752             | [] -> (* empty /etc/debian_version ...? *)
753                 LinuxRoot (UnknownArch, OtherLinux)
754             | line::_ -> (* try to detect version from /etc/debian_version *)
755                 try
756                   let subs = Pcre.exec ~rex:debian line in
757                   let major = int_of_string (Pcre.get_substring subs 1) in
758                   let minor = int_of_string (Pcre.get_substring subs 2) in
759                   LinuxRoot (UnknownArch, Debian (major, minor))
760                 with
761                   Not_found | Failure "int_of_string" ->
762                     LinuxRoot (UnknownArch, OtherLinux)
763           )
764           else
765             LinuxRoot (UnknownArch, OtherLinux)
766         ) else if is_dir (mnt ^ "/grub") = Some true &&
767           is_file (mnt ^ "/grub/stage1") = Some true then (
768             LinuxBoot
769         ) else
770           NotRoot (* mountable, but not a root filesystem *)
771     in
772
773     (* Examine the Linux root filesystem mounted on 'mnt' to
774      * determine the architecture. We do this by looking at some
775      * well-known binaries that we expect to be there.
776      *)
777     let detect_architecture mnt =
778       let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
779       match shget cmd with
780       | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
781       | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
782       | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
783       | _ -> UnknownArch
784     in
785
786     List.map (
787       fun part ->
788         let dev = dev_of_partition part in (* Get /dev device. *)
789
790         let nature =
791           (* Use 'file' command to detect if it is swap. *)
792           let cmd = "file -sbL " ^ quote dev in
793           match shget cmd with
794           | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
795           | _ ->
796               (* Blindly try to mount the device. *)
797               let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
798               match shwithstatus cmd with
799               | 0 ->
800                   let os = detect_os "/mnt/root" in
801                   let nature =
802                     match os with
803                     | LinuxRoot (UnknownArch, distro) ->
804                         let architecture = detect_architecture "/mnt/root" in
805                         LinuxRoot (architecture, distro)
806                     | os -> os in
807                   sh "umount /mnt/root";
808                   nature
809
810               | _ -> UnknownNature (* not mountable *)
811
812         in
813
814         eprintf "partition detection: %s is %s\n%!"
815           dev (string_of_nature nature);
816
817         (part, nature)
818     ) all_partitions
819   in
820
821   printf "virt-p2v finished detecting hard drives\n%!";
822
823   (* Dialogs. *)
824   let ask_greeting state =
825     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);
826     Next state
827   in
828
829   let ask_hostname state =
830     match
831     inputbox "Remote host" "Remote host" 10 50
832       (Option.default "" state.remote_host)
833     with
834     | Yes [] -> Ask_again
835     | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
836     | No | Help | Error -> Ask_again
837     | Back -> Prev
838   in
839
840   let ask_port state =
841     match
842     inputbox "Remote port" "Remote port" 10 50
843       (Option.default "22" state.remote_port)
844     with
845     | Yes ([]|""::_) -> Next { state with remote_port = Some "22" }
846     | Yes (port::_) -> Next { state with remote_port = Some port }
847     | No | Help | Error -> Ask_again
848     | Back -> Prev
849   in
850
851   let ask_directory state =
852     let default_dir = "/var/lib/xen/images" in
853     match
854     inputbox "Remote directory" "Remote directory" 10 50
855       (Option.default default_dir state.remote_directory)
856     with
857     | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir }
858     | Yes (dir::_) -> Next { state with remote_directory = Some dir }
859     | No | Help | Error -> Ask_again
860     | Back -> Prev
861   in
862
863   let ask_username state =
864     let default_username = "root" in
865     match
866     inputbox "Remote username" "Remote username for ssh access to server" 10 50
867       (Option.default default_username state.remote_username)
868     with
869     | Yes ([]|""::_) ->
870         Next { state with remote_username = Some default_username }
871     | Yes (user::_) -> Next { state with remote_username = Some user }
872     | No | Help | Error -> Ask_again
873     | Back -> Prev
874   in
875
876   let ask_network state =
877     match
878     radiolist "Network configuration" "Network configuration" 12 50 4 [
879       "auto", "Automatic configuration", state.network = Some Auto;
880       "ask", "Ask for fixed IP address and gateway",
881         state.network = Some Static;
882       "sh", "Configure from the shell", state.network = Some Shell;
883       "qemu", "QEMU user network (for developers only)",
884         state.network = Some QEMUUserNet
885     ]
886     with
887     | Yes ("auto"::_) -> Next { state with network = Some Auto }
888     | Yes ("ask"::_) -> Next { state with network = Some Static }
889     | Yes ("sh"::_) -> Next { state with network = Some Shell }
890     | Yes ("qemu"::_) -> Next { state with network = Some QEMUUserNet }
891     | Yes _ | No | Help | Error -> Ask_again
892     | Back -> Prev
893   in
894
895   let ask_static_network_config state =
896     let interface, address, netmask, gateway, nameserver =
897       match state.static_network_config with
898       | Some (a,b,c,d,e) -> a,b,c,d,e
899       | None -> "eth0","","","","" in
900     match
901     form "Static network configuration" "Static network configuration"
902       13 50 5 [
903         "Interface",  1, 0, interface,  1, 12, 8,  0;
904         "Address",    2, 0, address,    2, 12, 16, 0;
905         "Netmask",    3, 0, netmask,    3, 12, 16, 0;
906         "Gateway",    4, 0, gateway,    4, 12, 16, 0;
907         "Nameserver", 5, 0, nameserver, 5, 12, 16, 0;
908       ]
909     with
910     | Yes (interface::address::netmask::gateway::nameserver::_) ->
911         Next { state with
912                  static_network_config = Some (interface, address, netmask,
913                                                gateway, nameserver) }
914     | Yes _ | No | Help | Error -> Ask_again
915     | Back -> Prev
916   in
917
918   let ask_devices state =
919     let selected_devices = Option.default [] state.devices_to_send in
920     let devices = List.map (
921       fun (dev, blksize) ->
922         (dev,
923          sprintf "/dev/%s (%.3f GB)" dev
924            ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
925          List.mem dev selected_devices)
926     ) all_block_devices in
927     match
928     checklist "Devices" "Pick devices to send" 15 50 8 devices
929     with
930     | Yes [] | No | Help | Error -> Ask_again
931     | Yes devices -> Next { state with devices_to_send = Some devices }
932     | Back -> Prev
933   in
934
935   let ask_root state =
936     let parts = List.mapi (
937       fun i (part, nature) ->
938         let descr =
939           match nature with
940           | LinuxSwap -> " (Linux swap)"
941           | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
942           | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
943           | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
944           | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
945           | WindowsRoot -> " (Windows C:)"
946           | LinuxBoot -> " (Linux /boot)"
947           | NotRoot -> " (filesystem)"
948           | UnknownNature -> "" in
949         (string_of_int i,
950          dev_of_partition part ^ descr,
951          Some part = state.root_filesystem)
952     ) all_partitions in
953     match
954     radiolist "Root device"
955       "Pick partition containing the root (/) filesystem" 18 70 9
956       parts
957     with
958     | Yes (i::_) ->
959         let (part, _) = List.nth all_partitions (int_of_string i) in
960         Next { state with root_filesystem = Some part }
961     | Yes [] | No | Help | Error -> Ask_again
962     | Back -> Prev
963   in
964
965   let ask_hypervisor state =
966     match
967     radiolist "Hypervisor"
968       "Choose hypervisor / virtualization system"
969       11 50 4 [
970         "xen", "Xen", state.hypervisor = Some Xen;
971         "qemu", "QEMU", state.hypervisor = Some QEMU;
972         "kvm", "KVM", state.hypervisor = Some KVM;
973         "other", "Other", state.hypervisor = None
974       ]
975     with
976     | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
977     | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
978     | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
979     | Yes _ -> Next { state with hypervisor = None }
980     | No | Help | Error -> Ask_again
981     | Back -> Prev
982   in
983
984   let ask_architecture state =
985     match
986     radiolist "Architecture" "Machine architecture" 16 50 8 [
987       "i386", "i386 and up (32 bit)", state.architecture = Some I386;
988       "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
989       "ia64", "Itanium IA64", state.architecture = Some IA64;
990       "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
991       "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
992       "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
993       "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
994       "auto", "Auto-detect",
995         state.architecture = None || state.architecture = Some UnknownArch;
996     ]
997     with
998     | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
999     | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
1000     | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
1001     | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
1002     | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
1003     | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
1004     | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
1005     | Yes _ -> Next { state with architecture = Some UnknownArch }
1006     | No | Help | Error -> Ask_again
1007     | Back -> Prev
1008   in
1009
1010   let ask_memory state =
1011     match
1012     inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
1013       10 50
1014       (Option.map_default string_of_int "" state.memory)
1015     with
1016     | Yes (""::_ | []) -> Next { state with memory = Some 0 }
1017     | Yes (mem::_) ->
1018         let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
1019         if mem < 0 || (mem > 0 && mem < 64) then Ask_again
1020         else Next { state with memory = Some mem }
1021     | No | Help | Error -> Ask_again
1022     | Back -> Prev
1023   in
1024
1025   let ask_vcpus state =
1026     match
1027     inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
1028       10 50
1029       (Option.map_default string_of_int "" state.vcpus)
1030     with
1031     | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
1032     | Yes (vcpus::_) ->
1033         let vcpus =
1034           try int_of_string vcpus with Failure "int_of_string" -> -1 in
1035         if vcpus < 0 then Ask_again
1036         else Next { state with vcpus = Some vcpus }
1037     | No | Help | Error -> Ask_again
1038     | Back -> Prev
1039   in
1040
1041   let ask_mac_address state =
1042     match
1043     inputbox "MAC address"
1044       "Network MAC address. Leave blank to use a random address." 10 50
1045       (Option.default "" state.mac_address)
1046     with
1047     | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
1048     | Yes (mac :: _) -> Next { state with mac_address = Some mac }
1049     | No | Help | Error -> Ask_again
1050     | Back -> Prev
1051   in
1052
1053   let ask_verify state =
1054     match
1055     yesno "Verify and proceed"
1056       (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
1057
1058 Host:port:    %s : %s
1059 Directory:    %s
1060 Network:      %s
1061 Send devices: %s
1062 Root (/) dev: %s
1063 Hypervisor:   %s
1064 Architecture: %s
1065 Memory:       %s
1066 VCPUs:        %s
1067 MAC address:  %s"
1068          (Option.default "" state.remote_host)
1069          (Option.default "" state.remote_port)
1070          (Option.default "" state.remote_directory)
1071          (match state.network with
1072           | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
1073           | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net"
1074           | None -> "")
1075          (String.concat "," (Option.default [] state.devices_to_send))
1076          (Option.map_default dev_of_partition "" state.root_filesystem)
1077          (match state.hypervisor with
1078           | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
1079           | None -> "Other / not set")
1080          (match state.architecture with
1081           | Some UnknownArch -> "Auto-detect"
1082           | Some arch -> string_of_architecture arch | None -> "")
1083          (match state.memory with
1084           | Some 0 -> "Same as physical"
1085           | Some mem -> string_of_int mem ^ " MB" | None -> "")
1086          (match state.vcpus with
1087           | Some 0 -> "Same as physical"
1088           | Some vcpus -> string_of_int vcpus | None -> "")
1089          (match state.mac_address with
1090           | Some "" -> "Random" | Some mac -> mac | None -> "")
1091       )
1092       21 50
1093     with
1094     | Yes _ -> Next state
1095     | Back -> Prev
1096     | No | Help | Error -> Ask_again
1097   in
1098
1099   (* This is the list of dialogs, in order.  The user can go forwards or
1100    * backwards through them.
1101    *
1102    * The second parameter in each tuple is true if we need to skip
1103    * this dialog statically (info already supplied in 'defaults' above).
1104    *
1105    * The third parameter in each tuple is a function that tests whether
1106    * this dialog should be skipped, given other parts of the current state.
1107    *)
1108   let dlgs =
1109     let dont_skip _ = false in
1110     [|
1111     ask_greeting,      not defaults.greeting,             dont_skip;
1112     ask_hostname,      defaults.remote_host <> None,      dont_skip;
1113     ask_port,          defaults.remote_port <> None,      dont_skip;
1114     ask_directory,     defaults.remote_directory <> None, dont_skip;
1115     ask_username,      defaults.remote_username <> None,  dont_skip;
1116     ask_network,       defaults.network <> None,          dont_skip;
1117     ask_static_network_config,
1118       defaults.static_network_config <> None,
1119       (function { network = Some Static } -> false | _ -> true);
1120     ask_devices,       defaults.devices_to_send <> None,  dont_skip;
1121     ask_root,          defaults.root_filesystem <> None,  dont_skip;
1122     ask_hypervisor,    defaults.hypervisor <> None,       dont_skip;
1123     ask_architecture,  defaults.architecture <> None,     dont_skip;
1124     ask_memory,        defaults.memory <> None,           dont_skip;
1125     ask_vcpus,         defaults.vcpus <> None,            dont_skip;
1126     ask_mac_address,   defaults.mac_address <> None,      dont_skip;
1127     ask_verify,        not defaults.greeting,             dont_skip;
1128   |] in
1129
1130   (* Loop through the dialogs until we reach the end. *)
1131   let rec loop ?(back=false) posn state =
1132     eprintf "dialog loop: posn = %d, back = %b\n%!" posn back;
1133     if posn >= Array.length dlgs then state (* Finished all dialogs. *)
1134     else if posn < 0 then loop 0 state
1135     else (
1136       let dlg, skip_static, skip_dynamic = dlgs.(posn) in
1137       if skip_static || skip_dynamic state then
1138         (* Skip this dialog. *)
1139         loop ~back (if back then posn-1 else posn+1) state
1140       else (
1141         (* Run dialog. *)
1142         match dlg state with
1143         | Next new_state -> loop (posn+1) new_state (* Forwards. *)
1144         | Ask_again -> loop posn state  (* Repeat the question. *)
1145         | Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *)
1146       )
1147     )
1148   in
1149   let state = loop 0 defaults in
1150
1151   eprintf "finished dialog loop\n%!";
1152
1153   (* Switch LVM config. *)
1154   sh "vgchange -a n";
1155   putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1156   sh "rm -f /etc/lvm/cache/.cache";
1157   sh "rm -f /etc/lvm.new/cache/.cache";
1158
1159   (* Snapshot the block devices to send. *)
1160   let devices_to_send = Option.get state.devices_to_send in
1161   let devices_to_send =
1162     List.map (
1163       fun origin_dev ->
1164         let snapshot_dev = snapshot_name origin_dev in
1165         snapshot origin_dev snapshot_dev;
1166         (origin_dev, snapshot_dev)
1167     ) devices_to_send in
1168
1169   (* Run kpartx on the snapshots. *)
1170   List.iter (
1171     fun (origin, snapshot) ->
1172       shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1173   ) devices_to_send;
1174
1175   (* Rescan for LVs. *)
1176   sh "vgscan";
1177   sh "vgchange -a y";
1178
1179   (* Mount the root filesystem under /mnt/root. *)
1180   let root_filesystem = Option.get state.root_filesystem in
1181   (match root_filesystem with
1182    | Part (dev, partnum) ->
1183        let dev = dev ^ partnum in
1184        let snapshot_dev = snapshot_name dev in
1185        sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1186
1187    | LV (vg, lv) ->
1188        (* The LV will be backed by a snapshot device, so just mount
1189         * directly.
1190         *)
1191        sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1192   );
1193
1194   (* See if we can do network configuration. *)
1195   let network = Option.get state.network in
1196   (match network with
1197    | Shell ->
1198        printf "Network configuration.\n\n";
1199        printf "Please configure the network from this shell.\n\n";
1200        printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1201        shell ()
1202
1203    | Static ->
1204        printf "Trying static network configuration.\n\n%!";
1205        if not (static_network state) then (
1206          printf "\nAuto-configuration failed.  Starting a shell.\n\n";
1207          printf "Please configure the network from this shell.\n\n";
1208          printf "When you have finished, exit the shell with ^D or exit.\n\n";
1209          shell ()
1210        )
1211
1212    | Auto ->
1213        printf
1214          "Trying network auto-configuration from root filesystem ...\n\n%!";
1215        if not (auto_network state) then (
1216          printf "\nAuto-configuration failed.  Starting a shell.\n\n";
1217          printf "Please configure the network from this shell.\n\n";
1218          printf "When you have finished, exit the shell with ^D or exit.\n\n";
1219          shell ()
1220        )
1221    | QEMUUserNet ->
1222        printf "Trying QEMU network configuration.\n\n%!";
1223        qemu_network ()
1224   );
1225
1226   (* Work out what devices will be called at the remote end. *)
1227   let devices_to_send = List.map (
1228     fun (origin_dev, snapshot_dev) ->
1229       let remote_dev = remote_of_origin_dev origin_dev in
1230       (origin_dev, snapshot_dev, remote_dev)
1231   ) devices_to_send in
1232
1233   (* Modify files on the root filesystem. *)
1234   rewrite_fstab state devices_to_send;
1235   (* XXX Other files to rewrite? *)
1236
1237   (* Unmount the root filesystem and sync disks. *)
1238   sh "umount /mnt/root";
1239   sh "sync";                            (* Ugh, should be in stdlib. *)
1240
1241   (* Get architecture of root filesystem, detected previously. *)
1242   let system_architecture =
1243     try
1244       (match List.assoc root_filesystem all_partitions with
1245        | LinuxRoot (arch, _) -> arch
1246        | _ -> raise Not_found
1247       )
1248     with
1249       Not_found ->
1250         (* None was detected before, so assume same as live CD. *)
1251         let arch = shget "uname -m" in
1252         match arch with
1253         | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
1254         | Some ("x86_64"::_) -> X86_64
1255         | Some ("ia64"::_) -> IA64
1256         | _ -> I386 (* probably wrong XXX *) in
1257
1258   (* Autodetect system memory. *)
1259   let system_memory =
1260     let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
1261     match mem with
1262     | Some (mem::_) -> int_of_float (float_of_string mem)
1263     | _ -> 256 in
1264
1265   (* Autodetect system # pCPUs. *)
1266   let system_nr_cpus =
1267     let cpus =
1268       shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
1269     match cpus with
1270     | Some (cpus::_) -> int_of_string cpus
1271     | _ -> 1 in
1272
1273   let remote_host = Option.get state.remote_host in
1274   let remote_port = Option.get state.remote_port in
1275   let remote_directory = Option.get state.remote_directory in
1276   let remote_username = Option.get state.remote_username in
1277
1278   (* Functions to connect and disconnect from the remote system. *)
1279   let do_connect remote_name _ =
1280     let cmd = sprintf "ssh -C -l %s -p %s %s \"cat > %s/%s\""
1281       (quote remote_username) (quote remote_port) (quote remote_host)
1282       (quote remote_directory) (quote remote_name) in
1283     eprintf "connect: %s\n%!" cmd;
1284     let chan = open_process_out cmd in
1285     descr_of_out_channel chan, chan
1286   in
1287   let do_disconnect (_, chan) =
1288     match close_process_out chan with
1289     | WEXITED 0 -> ()           (* OK *)
1290     | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
1291     | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
1292     | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
1293   in
1294
1295   (* XXX This is using the hostname derived from network configuration
1296    * above.  We might want to ask the user to choose.
1297    *)
1298   let hostname = safe_name (gethostname ()) in
1299   let basename =
1300     let date = sprintf "%04d%02d%02d%02d%02d"
1301       (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1302     "p2v-" ^ hostname ^ "-" ^ date in
1303
1304   (* Work out what the image filenames will be at the remote end. *)
1305   let devices_to_send = List.map (
1306     fun (origin_dev, snapshot_dev, remote_dev) ->
1307       let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1308       (origin_dev, snapshot_dev, remote_dev, remote_name)
1309   ) devices_to_send in
1310
1311   (* Write a configuration file.  Not sure if this is any better than
1312    * just 'sprintf-ing' bits of XML text together, but at least we will
1313    * always get well-formed XML.
1314    *
1315    * XXX For some of the stuff here we really should do a
1316    * virConnectGetCapabilities call to the remote host first.
1317    *
1318    * XXX There is a case for using virt-install to generate this XML.
1319    * When we start to incorporate libvirt access & storage API this
1320    * needs to be rethought.
1321    *)
1322   let conf_filename = basename ^ ".conf" in
1323
1324   let architecture =
1325     match state.architecture with
1326     | Some UnknownArch | None -> system_architecture
1327     | Some arch -> arch in
1328   let memory =
1329     match state.memory with
1330     | Some 0 | None -> system_memory
1331     | Some memory -> memory in
1332   let vcpus =
1333     match state.vcpus with
1334     | Some 0 | None -> system_nr_cpus
1335     | Some n -> n in
1336   let mac_address =
1337     match state.mac_address with
1338     | Some "" | None -> random_mac_address ()
1339     | Some mac -> mac in
1340
1341   let xml =
1342     (* Shortcut to make "<name>value</name>". *)
1343     let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1344     (* ... and the _other_ sort of leaf (god I hate XML). *)
1345     let tleaf name attribs = Xml.Element (name, attribs, []) in
1346
1347     (* Standard stuff for every domain. *)
1348     let name = leaf "name" hostname in
1349     let uuid = leaf "uuid" (random_uuid ()) in
1350     let maxmem = leaf "maxmem" (string_of_int (memory * 1024)) in
1351     let memory = leaf "memory" (string_of_int (memory * 1024)) in
1352     let vcpu = leaf "vcpu" (string_of_int vcpus) in
1353
1354     (* Top-level stuff which differs for each HV type (isn't this supposed
1355      * to be portable ...)
1356      *)
1357     let extras =
1358       match state.hypervisor with
1359       | Some Xen ->
1360           [Xml.Element ("os", [],
1361                         [leaf "type" "hvm";
1362                          leaf "loader" "/usr/lib/xen/boot/hvmloader";
1363                          tleaf "boot" ["dev", "hd"]]);
1364            Xml.Element ("features", [],
1365                         [tleaf "pae" [];
1366                          tleaf "acpi" [];
1367                          tleaf "apic" []]);
1368            tleaf "clock" ["sync", "localtime"]]
1369       | Some KVM ->
1370           [Xml.Element ("os", [], [leaf "type" "hvm"]);
1371            tleaf "clock" ["sync", "localtime"]]
1372       | Some QEMU ->
1373           [Xml.Element ("os", [],
1374                         [Xml.Element ("type",
1375                                       ["arch",
1376                                        string_of_architecture architecture;
1377                                        "machine","pc"],
1378                                       [Xml.PCData "hvm"]);
1379                          tleaf "boot" ["dev", "hd"]])]
1380       | None ->
1381           [] in
1382
1383     (* <devices> section. *)
1384     let devices =
1385       let emulator =
1386         match state.hypervisor with
1387         | Some Xen ->
1388             [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1389         | Some QEMU ->
1390             [leaf "emulator" "/usr/bin/qemu"]
1391         | Some KVM ->
1392             [leaf "emulator" "/usr/bin/qemu-kvm"]
1393         | None ->
1394             [] in
1395       let interface =
1396         Xml.Element ("interface", ["type", "user"],
1397                      [tleaf "mac" ["address", mac_address]]) in
1398       (* XXX should have an option for Xen bridging:
1399         Xml.Element (
1400         "interface", ["type","bridge"],
1401         [tleaf "source" ["bridge","xenbr0"];
1402         tleaf "mac" ["address",mac_address];
1403         tleaf "script" ["path","vif-bridge"]])*)
1404       let graphics = tleaf "graphics" ["type", "vnc"] in
1405
1406       let disks = List.map (
1407         fun (_, _, remote_dev, remote_name) ->
1408           Xml.Element (
1409             "disk", ["type", "file";
1410                      "device", "disk"],
1411             [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1412              tleaf "target" ["dev", remote_dev]]
1413           )
1414       ) devices_to_send in
1415
1416       Xml.Element (
1417         "devices", [],
1418         emulator @ interface :: graphics :: disks
1419       ) in
1420
1421     (* Put it all together in <domain type='foo'>. *)
1422     Xml.Element (
1423       "domain",
1424       (match state.hypervisor with
1425        | Some Xen -> ["type", "xen"]
1426        | Some QEMU -> ["type", "qemu"]
1427        | Some KVM -> ["type", "kvm"]
1428        | None -> []),
1429       name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
1430     ) in
1431
1432   (* Convert XML configuration file to a string, then send it to the
1433    * remote server.
1434    *)
1435   let () =
1436     let xml = Xml.to_string_fmt xml in
1437
1438     let conn_arg =
1439       match state.hypervisor with
1440       | Some Xen | None -> ""
1441       | Some QEMU | Some KVM -> " -c qemu:///system" in
1442     let xml = sprintf "\
1443 <!--
1444   This is a libvirt configuration file.
1445
1446   To start the domain, do:
1447     virsh%s define %s
1448     virsh%s start %s
1449 -->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in
1450
1451     let xml_len = String.length xml in
1452     eprintf "length of configuration file is %d bytes\n%!" xml_len;
1453
1454     let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1455     (* In OCaml this actually loops calling write(2) *)
1456     ignore (write sock xml 0 xml_len);
1457     do_disconnect conn in
1458
1459   (* Send the device snapshots to the remote host. *)
1460   (* XXX This code should be made more robust against both network
1461    * errors and local I/O errors.  Also should allow the user several
1462    * attempts to connect, or let them go back to the dialog stage.
1463    *)
1464   List.iter (
1465     fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1466       eprintf "sending %s as %s\n%!" origin_dev remote_name;
1467
1468       let size =
1469         try List.assoc origin_dev all_block_devices
1470         with Not_found -> assert false (* internal error *) in
1471
1472       printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1473         ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1474
1475       (* Open the snapshot device. *)
1476       let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1477
1478       (* Now connect. *)
1479       let (sock,_) as conn = do_connect remote_name size in
1480
1481       (* Copy the data. *)
1482       let bufsize = 1024 * 1024 in
1483       let buffer = String.create bufsize in
1484       let start = gettimeofday () in
1485
1486       let rec copy bytes_sent last_printed_at =
1487         let n = read fd buffer 0 bufsize in
1488         if n > 0 then (
1489           ignore (write sock buffer 0 n);
1490
1491           let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1492           let last_printed_at =
1493             let now = gettimeofday () in
1494             (* Print progress once per second. *)
1495             if now -. last_printed_at > 1. then (
1496               let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1497               let secs_elapsed = now -. start in
1498               printf "%.0f%%" (100. *. elapsed);
1499               (* After 60 seconds has elapsed, start printing estimates. *)
1500               if secs_elapsed >= 60. then (
1501                 let remaining = 1. -. elapsed in
1502                 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1503                 if secs_remaining > 120. then
1504                   printf " (about %.0f minutes remaining)          "
1505                     (secs_remaining /. 60.)
1506                 else
1507                   printf " (about %.0f seconds remaining)          "
1508                     secs_remaining
1509               );
1510               printf "\r%!";
1511               now
1512             )
1513             else last_printed_at in
1514
1515           copy bytes_sent last_printed_at
1516         )
1517       in
1518       copy 0L start;
1519
1520       (* Disconnect. *)
1521       do_disconnect conn
1522   ) devices_to_send;
1523
1524   (* Clean up and reboot. *)
1525   ignore (
1526     msgbox "virt-p2v completed"
1527       (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."
1528          remote_directory conf_filename)
1529       17 50
1530   );
1531
1532   shfailok "eject";
1533   shfailok "reboot";
1534   exit 0
1535
1536 let usage () =
1537   eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
1538   exit 2
1539
1540 (* Make sure that exceptions from 'main' get printed out on stdout
1541  * as well as stderr, since stderr is probably redirected to the
1542  * logfile, and so not visible to the user.
1543  *)
1544 let handle_exn f arg =
1545   try f arg
1546   with exn -> print_endline (Printexc.to_string exn); raise exn
1547
1548 (* Test harness for the Makefile.  The Makefile invokes this script as
1549  * 'virt-p2v --test' just to check it compiles.  When it is running
1550  * from the actual live CD, there is a single parameter which is the
1551  * tty name (so usually 'virt-p2v tty1').
1552  *)
1553 let () =
1554   match Array.to_list Sys.argv with
1555   | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1556   | [ _; "--test" ] -> ()               (* Makefile test - do nothing. *)
1557   | [ _; ttyname ] ->                   (* Run main with ttyname. *)
1558       handle_exn main (Some ttyname)
1559   | [ _ ] ->                            (* Interactive - no ttyname. *)
1560       handle_exn main None
1561   | _ -> usage ()
1562
1563 (* This file must end with a newline *)