Remove redundant/commented code.
[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   (* NB. Lazy unmount is required because dhclient keeps its current
454    * directory open on /etc/sysconfig/network-scripts/
455    *)
456   sh "mount -o bind /mnt/root/etc /etc";
457   let status = shwithstatus "/etc/init.d/network start" in
458   sh "umount -l /etc";
459
460   (* Try to ping the remote host to see if this worked. *)
461   shfailok ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
462
463   if state.greeting then (
464     printf "\n\nDid automatic network configuration work?\n";
465     printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
466     printf "    (y/n) %!";
467     let line = read_line () in
468     String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
469   )
470   else
471     (* Non-interactive: return the status of /etc/init.d/network start. *)
472     status = 0
473
474 (* Configure the network statically. *)
475 let static_network state =
476   match state.static_network_config with
477   | None -> false                       (* failed *)
478   | Some (interface, address, netmask, gateway, nameserver) ->
479       let do_cmd_or_exit cmd = if shwithstatus cmd <> 0 then raise Exit in
480       try
481         do_cmd_or_exit (sprintf "ifconfig %s %s netmask %s"
482                           (quote interface) (quote address) (quote netmask));
483         do_cmd_or_exit (sprintf "route add default gw %s %s"
484                           (quote gateway) (quote interface));
485         if nameserver <> "" then
486           do_cmd_or_exit (sprintf "echo nameserver %s > /etc/resolv.conf"
487                             (quote nameserver));
488         true                            (* succeeded *)
489       with
490         Exit -> false                   (* failed *)
491
492 let qemu_network () =
493   sh "ifconfig eth0 10.0.2.10 netmask 255.255.255.0";
494   sh "route add default gw 10.0.2.2 eth0";
495   sh "echo nameserver 10.0.2.3 > /etc/resolv.conf"
496
497 (* Map local device names to remote devices names.  At the moment we
498  * just change sd* to hd* (as device names appear under fullvirt).  In
499  * future, lots of complex possibilities.
500  *)
501 let remote_of_origin_dev =
502   let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]*)$" in
503   let devsd_subst = Pcre.subst "hd$1" in
504   fun dev ->
505     Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
506
507 (* Rewrite /mnt/root/etc/fstab. *)
508 let rewrite_fstab state devices_to_send =
509   let filename = "/mnt/root/etc/fstab" in
510   if is_file filename = Some true then (
511     sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
512
513     let chan = open_in filename in
514     let lines = input_all_lines chan in
515     close_in chan;
516     let lines = List.map (Pcre.split ~rex:whitespace) lines in
517     let lines = List.map (
518       function
519       | dev :: rest when String.starts_with dev "/dev/" ->
520           let dev = String.sub dev 5 (String.length dev - 5) in
521           let dev = remote_of_origin_dev dev in
522           let dev = "/dev/" ^ dev in
523           dev :: rest
524       | line -> line
525     ) lines in
526
527     let chan = open_out filename in
528     List.iter (
529       function
530       | [dev; mountpoint; fstype; options; freq; passno] ->
531           fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
532             dev mountpoint fstype options freq passno
533       | line ->
534           output_string chan (String.concat " " line)
535     ) lines;
536     close_out chan
537   )
538
539 let () = Random.self_init ()
540
541 let random_mac_address () =
542   let random =
543     List.map (sprintf "%02x") (
544       List.map (fun _ -> Random.int 256) [0;0;0]
545     ) in
546   String.concat ":" ("00"::"16"::"3e"::random)
547
548 let random_uuid =
549   let hex = "0123456789abcdef" in
550   fun () ->
551   let str = String.create 32 in
552   for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
553   str
554
555 (* Main entry point. *)
556 let rec main ttyname =
557   (* Running from an init script.  We don't have much of a
558    * login environment, so set one up.
559    *)
560   putenv "PATH"
561     (String.concat ":"
562        ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
563         "/usr/bin"; "/bin"]);
564   putenv "HOME" "/root";
565   putenv "LOGNAME" "root";
566
567   (* We can safely write in /tmp (it's a synthetic live CD directory). *)
568   chdir "/tmp";
569
570   (* Set up logging to /tmp/virt-p2v.log. *)
571   let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
572   dup2 fd stderr;
573   close fd;
574
575   (* Log the start up time. *)
576   eprintf "\n\n**************************************************\n\n";
577   let tm = localtime (time ()) in
578   eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
579     (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
580
581   (* Connect stdin/stdout to the tty. *)
582   (match ttyname with
583    | None -> ()
584    | Some ttyname ->
585        let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
586        dup2 fd stdin;
587        dup2 fd stdout;
588        close fd);
589   printf "virt-p2v starting up ...\n%!";
590
591   (* Disable screen blanking on tty. *)
592   sh "setterm -blank 0";
593
594   (* Check that the environment is a sane-looking live CD.  If not, bail. *)
595   if is_dir "/mnt/root" <> Some true then
596     fail_dialog
597       "You should only run this script from the live CD or a USB key.";
598
599   printf "virt-p2v detecting hard drives (this may take some time) ...\n%!";
600
601   (* Search for all non-removable block devices.  Do this early and bail
602    * if we can't find anything.  This is a list of strings, like "hda".
603    *)
604   let all_block_devices : block_device list =
605     let rex = Pcre.regexp "^[hs]d" in
606     let devices = Array.to_list (Sys.readdir "/sys/block") in
607     let devices = List.sort devices in
608     let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
609     eprintf "all_block_devices: block devices: %s\n%!"
610       (String.concat "; " devices);
611     (* Run blockdev --getsize64 on each, and reject any where this fails
612      * (probably removable devices).
613      *)
614     let devices = List.filter_map (
615       fun d ->
616         let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
617         let lines = shget cmd in
618         match lines with
619         | Some (blksize::_) -> Some (d, Int64.of_string blksize)
620         | Some [] | None -> None
621     ) devices in
622     eprintf "all_block_devices: non-removable block devices: %s\n%!"
623       (String.concat "; "
624          (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
625     if devices = [] then
626       fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
627     devices in
628
629   (* Search for partitions and LVs (anything that could contain a
630    * filesystem directly).  We refer to these generically as
631    * "partitions".
632    *)
633   let all_partitions : partition list =
634     (* LVs & PVs. *)
635     let lvs, pvs =
636       let lvs = get_lvs () in
637       let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
638       let pvs = List.concat pvs in
639       let pvs = sort_uniq pvs in
640       eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
641       let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
642       eprintf "all_partitions: LVs: %s\n%!"
643         (String.concat "; " (List.map dev_of_partition lvs));
644       lvs, pvs in
645
646     (* Partitions (eg. "sda1", "sda2"). *)
647     let parts =
648       let parts = List.map fst all_block_devices in
649       let parts = List.map get_partitions parts in
650       let parts = List.concat parts in
651       eprintf "all_partitions: all partitions: %s\n%!"
652         (String.concat "; " (List.map dev_of_partition parts));
653
654       (* Remove any partitions which are PVs. *)
655       let parts = List.filter (
656         function
657         | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
658         | LV _ -> assert false
659       ) parts in
660       parts in
661     eprintf "all_partitions: partitions after removing PVs: %s\n%!"
662       (String.concat "; " (List.map dev_of_partition parts));
663
664     (* Concatenate LVs & Parts *)
665     lvs @ parts in
666
667   (* Try to determine the nature of each partition.
668    * Root? Swap? Architecture? etc.
669    *)
670   let all_partitions : (partition * nature) list =
671     (* Output of 'file' command for Linux swap file. *)
672     let swap = Pcre.regexp "Linux.*swap.*file" in
673     (* Contents of /etc/redhat-release. *)
674     let rhel = Pcre.regexp "(?:Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\\d+)(?:\\.(\\d+))?" in
675     let fedora = Pcre.regexp "Fedora.*release (\\d+)" in
676     (* Contents of /etc/debian_version. *)
677     let debian = Pcre.regexp "^(\\d+)\\.(\\d+)" in
678     (* Output of 'file' on certain executables. *)
679     let i386 = Pcre.regexp ", Intel 80386," in
680     let x86_64 = Pcre.regexp ", x86-64," in
681     let itanic = Pcre.regexp ", IA-64," in
682
683     (* Examine the filesystem mounted on 'mnt' to determine the
684      * operating system, and, if Linux, the distro.
685      *)
686     let detect_os mnt =
687       if is_dir (mnt ^ "/Windows") = Some true &&
688         is_file (mnt ^ "/autoexec.bat") = Some true then
689           WindowsRoot
690       else if is_dir (mnt ^ "/etc") = Some true &&
691         is_dir (mnt ^ "/sbin") = Some true &&
692         is_dir (mnt ^ "/var") = Some true then (
693           if is_file (mnt ^ "/etc/redhat-release") = Some true then (
694             let chan = open_in (mnt ^ "/etc/redhat-release") in
695             let lines = input_all_lines chan in
696             close_in chan;
697
698             match lines with
699             | [] -> (* empty /etc/redhat-release ...? *)
700                 LinuxRoot (UnknownArch, OtherLinux)
701             | line::_ -> (* try to detect OS from /etc/redhat-release *)
702                 try
703                   let subs = Pcre.exec ~rex:rhel line in
704                   let major = int_of_string (Pcre.get_substring subs 1) in
705                   let minor =
706                     try int_of_string (Pcre.get_substring subs 2)
707                     with Not_found -> 0 in
708                   LinuxRoot (UnknownArch, RHEL (major, minor))
709                 with
710                   Not_found | Failure "int_of_string" ->
711                     try
712                       let subs = Pcre.exec ~rex:fedora line in
713                       let version = int_of_string (Pcre.get_substring subs 1) in
714                       LinuxRoot (UnknownArch, Fedora version)
715                     with
716                       Not_found | Failure "int_of_string" ->
717                         LinuxRoot (UnknownArch, OtherLinux)
718           )
719           else if is_file (mnt ^ "/etc/debian_version") = Some true then (
720             let chan = open_in (mnt ^ "/etc/debian_version") in
721             let lines = input_all_lines chan in
722             close_in chan;
723
724             match lines with
725             | [] -> (* empty /etc/debian_version ...? *)
726                 LinuxRoot (UnknownArch, OtherLinux)
727             | line::_ -> (* try to detect version from /etc/debian_version *)
728                 try
729                   let subs = Pcre.exec ~rex:debian line in
730                   let major = int_of_string (Pcre.get_substring subs 1) in
731                   let minor = int_of_string (Pcre.get_substring subs 2) in
732                   LinuxRoot (UnknownArch, Debian (major, minor))
733                 with
734                   Not_found | Failure "int_of_string" ->
735                     LinuxRoot (UnknownArch, OtherLinux)
736           )
737           else
738             LinuxRoot (UnknownArch, OtherLinux)
739         ) else if is_dir (mnt ^ "/grub") = Some true &&
740           is_file (mnt ^ "/grub/stage1") = Some true then (
741             LinuxBoot
742         ) else
743           NotRoot (* mountable, but not a root filesystem *)
744     in
745
746     (* Examine the Linux root filesystem mounted on 'mnt' to
747      * determine the architecture. We do this by looking at some
748      * well-known binaries that we expect to be there.
749      *)
750     let detect_architecture mnt =
751       let cmd = "file -bL " ^ quote (mnt ^ "/sbin/init") in
752       match shget cmd with
753       | Some (str::_) when Pcre.pmatch ~rex:i386 str -> I386
754       | Some (str::_) when Pcre.pmatch ~rex:x86_64 str -> X86_64
755       | Some (str::_) when Pcre.pmatch ~rex:itanic str -> IA64
756       | _ -> UnknownArch
757     in
758
759     List.map (
760       fun part ->
761         let dev = dev_of_partition part in (* Get /dev device. *)
762
763         let nature =
764           (* Use 'file' command to detect if it is swap. *)
765           let cmd = "file -sbL " ^ quote dev in
766           match shget cmd with
767           | Some (str::_) when Pcre.pmatch ~rex:swap str -> LinuxSwap
768           | _ ->
769               (* Blindly try to mount the device. *)
770               let cmd = "mount -o ro " ^ quote dev ^ " /mnt/root" in
771               match shwithstatus cmd with
772               | 0 ->
773                   let os = detect_os "/mnt/root" in
774                   let nature =
775                     match os with
776                     | LinuxRoot (UnknownArch, distro) ->
777                         let architecture = detect_architecture "/mnt/root" in
778                         LinuxRoot (architecture, distro)
779                     | os -> os in
780                   sh "umount /mnt/root";
781                   nature
782
783               | _ -> UnknownNature (* not mountable *)
784
785         in
786
787         eprintf "partition detection: %s is %s\n%!"
788           dev (string_of_nature nature);
789
790         (part, nature)
791     ) all_partitions
792   in
793
794   printf "virt-p2v finished detecting hard drives\n%!";
795
796   (* Dialogs. *)
797   let ask_greeting state =
798     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);
799     Next state
800   in
801
802   let ask_hostname state =
803     match
804     inputbox "Remote host" "Remote host" 10 50
805       (Option.default "" state.remote_host)
806     with
807     | Yes [] -> Ask_again
808     | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
809     | No | Help | Error -> Ask_again
810     | Back -> Prev
811   in
812
813   let ask_port state =
814     match
815     inputbox "Remote port" "Remote port" 10 50
816       (Option.default "22" state.remote_port)
817     with
818     | Yes ([]|""::_) -> Next { state with remote_port = Some "22" }
819     | Yes (port::_) -> Next { state with remote_port = Some port }
820     | No | Help | Error -> Ask_again
821     | Back -> Prev
822   in
823
824   let ask_directory state =
825     let default_dir = "/var/lib/xen/images" in
826     match
827     inputbox "Remote directory" "Remote directory" 10 50
828       (Option.default default_dir state.remote_directory)
829     with
830     | Yes ([]|""::_) -> Next { state with remote_directory = Some default_dir }
831     | Yes (dir::_) -> Next { state with remote_directory = Some dir }
832     | No | Help | Error -> Ask_again
833     | Back -> Prev
834   in
835
836   let ask_username state =
837     let default_username = "root" in
838     match
839     inputbox "Remote username" "Remote username for ssh access to server" 10 50
840       (Option.default default_username state.remote_username)
841     with
842     | Yes ([]|""::_) ->
843         Next { state with remote_username = Some default_username }
844     | Yes (user::_) -> Next { state with remote_username = Some user }
845     | No | Help | Error -> Ask_again
846     | Back -> Prev
847   in
848
849   let ask_network state =
850     match
851     radiolist "Network configuration" "Network configuration" 12 50 4 [
852       "auto", "Automatic configuration", state.network = Some Auto;
853       "ask", "Ask for fixed IP address and gateway",
854         state.network = Some Static;
855       "sh", "Configure from the shell", state.network = Some Shell;
856       "qemu", "QEMU user network (for developers only)",
857         state.network = Some QEMUUserNet
858     ]
859     with
860     | Yes ("auto"::_) -> Next { state with network = Some Auto }
861     | Yes ("ask"::_) -> Next { state with network = Some Static }
862     | Yes ("sh"::_) -> Next { state with network = Some Shell }
863     | Yes ("qemu"::_) -> Next { state with network = Some QEMUUserNet }
864     | Yes _ | No | Help | Error -> Ask_again
865     | Back -> Prev
866   in
867
868   let ask_static_network_config state =
869     let interface, address, netmask, gateway, nameserver =
870       match state.static_network_config with
871       | Some (a,b,c,d,e) -> a,b,c,d,e
872       | None -> "eth0","","","","" in
873     match
874     form "Static network configuration" "Static network configuration"
875       13 50 5 [
876         "Interface",  1, 0, interface,  1, 12, 8,  0;
877         "Address",    2, 0, address,    2, 12, 16, 0;
878         "Netmask",    3, 0, netmask,    3, 12, 16, 0;
879         "Gateway",    4, 0, gateway,    4, 12, 16, 0;
880         "Nameserver", 5, 0, nameserver, 5, 12, 16, 0;
881       ]
882     with
883     | Yes (interface::address::netmask::gateway::nameserver::_) ->
884         Next { state with
885                  static_network_config = Some (interface, address, netmask,
886                                                gateway, nameserver) }
887     | Yes _ | No | Help | Error -> Ask_again
888     | Back -> Prev
889   in
890
891   let ask_devices state =
892     let selected_devices = Option.default [] state.devices_to_send in
893     let devices = List.map (
894       fun (dev, blksize) ->
895         (dev,
896          sprintf "/dev/%s (%.3f GB)" dev
897            ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
898          List.mem dev selected_devices)
899     ) all_block_devices in
900     match
901     checklist "Devices" "Pick devices to send" 15 50 8 devices
902     with
903     | Yes [] | No | Help | Error -> Ask_again
904     | Yes devices -> Next { state with devices_to_send = Some devices }
905     | Back -> Prev
906   in
907
908   let ask_root state =
909     let parts = List.mapi (
910       fun i (part, nature) ->
911         let descr =
912           match nature with
913           | LinuxSwap -> " (Linux swap)"
914           | LinuxRoot (_, RHEL (a,b)) -> sprintf " (RHEL %d.%d root)" a b
915           | LinuxRoot (_, Fedora v) -> sprintf " (Fedora %d root)" v
916           | LinuxRoot (_, Debian (a,b)) -> sprintf " (Debian %d.%d root)" a b
917           | LinuxRoot (_, OtherLinux) -> sprintf " (Linux root)"
918           | WindowsRoot -> " (Windows C:)"
919           | LinuxBoot -> " (Linux /boot)"
920           | NotRoot -> " (filesystem)"
921           | UnknownNature -> "" in
922         (string_of_int i,
923          dev_of_partition part ^ descr,
924          Some part = state.root_filesystem)
925     ) all_partitions in
926     match
927     radiolist "Root device"
928       "Pick partition containing the root (/) filesystem" 18 70 9
929       parts
930     with
931     | Yes (i::_) ->
932         let (part, _) = List.nth all_partitions (int_of_string i) in
933         Next { state with root_filesystem = Some part }
934     | Yes [] | No | Help | Error -> Ask_again
935     | Back -> Prev
936   in
937
938   let ask_hypervisor state =
939     match
940     radiolist "Hypervisor"
941       "Choose hypervisor / virtualization system"
942       11 50 4 [
943         "xen", "Xen", state.hypervisor = Some Xen;
944         "qemu", "QEMU", state.hypervisor = Some QEMU;
945         "kvm", "KVM", state.hypervisor = Some KVM;
946         "other", "Other", state.hypervisor = None
947       ]
948     with
949     | Yes ("xen"::_) -> Next { state with hypervisor = Some Xen }
950     | Yes ("qemu"::_) -> Next { state with hypervisor = Some QEMU }
951     | Yes ("kvm"::_) -> Next { state with hypervisor = Some KVM }
952     | Yes _ -> Next { state with hypervisor = None }
953     | No | Help | Error -> Ask_again
954     | Back -> Prev
955   in
956
957   let ask_architecture state =
958     match
959     radiolist "Architecture" "Machine architecture" 16 50 8 [
960       "i386", "i386 and up (32 bit)", state.architecture = Some I386;
961       "x86_64", "x86-64 (64 bit)", state.architecture = Some X86_64;
962       "ia64", "Itanium IA64", state.architecture = Some IA64;
963       "ppc", "PowerPC (32 bit)", state.architecture = Some PPC;
964       "ppc64", "PowerPC (64 bit)", state.architecture = Some PPC64;
965       "sparc", "SPARC (32 bit)", state.architecture = Some SPARC;
966       "sparc64", "SPARC (64 bit)", state.architecture = Some SPARC64;
967       "auto", "Auto-detect",
968         state.architecture = None || state.architecture = Some UnknownArch;
969     ]
970     with
971     | Yes ("i386" :: _) -> Next { state with architecture = Some I386 }
972     | Yes ("x86_64" :: _) -> Next { state with architecture = Some X86_64 }
973     | Yes ("ia64" :: _) -> Next { state with architecture = Some IA64 }
974     | Yes ("ppc" :: _) -> Next { state with architecture = Some PPC }
975     | Yes ("ppc64" :: _) -> Next { state with architecture = Some PPC64 }
976     | Yes ("sparc" :: _) -> Next { state with architecture = Some SPARC }
977     | Yes ("sparc64" :: _) -> Next { state with architecture = Some SPARC64 }
978     | Yes _ -> Next { state with architecture = Some UnknownArch }
979     | No | Help | Error -> Ask_again
980     | Back -> Prev
981   in
982
983   let ask_memory state =
984     match
985     inputbox "Memory" "Memory (MB). Leave blank to use same as physical server."
986       10 50
987       (Option.map_default string_of_int "" state.memory)
988     with
989     | Yes (""::_ | []) -> Next { state with memory = Some 0 }
990     | Yes (mem::_) ->
991         let mem = try int_of_string mem with Failure "int_of_string" -> -1 in
992         if mem < 0 || (mem > 0 && mem < 64) then Ask_again
993         else Next { state with memory = Some mem }
994     | No | Help | Error -> Ask_again
995     | Back -> Prev
996   in
997
998   let ask_vcpus state =
999     match
1000     inputbox "VCPUs" "Virtual CPUs. Leave blank to use same as physical server."
1001       10 50
1002       (Option.map_default string_of_int "" state.vcpus)
1003     with
1004     | Yes (""::_ | []) -> Next { state with vcpus = Some 0 }
1005     | Yes (vcpus::_) ->
1006         let vcpus =
1007           try int_of_string vcpus with Failure "int_of_string" -> -1 in
1008         if vcpus < 0 then Ask_again
1009         else Next { state with vcpus = Some vcpus }
1010     | No | Help | Error -> Ask_again
1011     | Back -> Prev
1012   in
1013
1014   let ask_mac_address state =
1015     match
1016     inputbox "MAC address"
1017       "Network MAC address. Leave blank to use a random address." 10 50
1018       (Option.default "" state.mac_address)
1019     with
1020     | Yes (""::_ | []) -> Next { state with mac_address = Some "" }
1021     | Yes (mac :: _) -> Next { state with mac_address = Some mac }
1022     | No | Help | Error -> Ask_again
1023     | Back -> Prev
1024   in
1025
1026   let ask_verify state =
1027     match
1028     yesno "Verify and proceed"
1029       (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
1030
1031 Host:port:    %s : %s
1032 Directory:    %s
1033 Network:      %s
1034 Send devices: %s
1035 Root (/) dev: %s
1036 Hypervisor:   %s
1037 Architecture: %s
1038 Memory:       %s
1039 VCPUs:        %s
1040 MAC address:  %s"
1041          (Option.default "" state.remote_host)
1042          (Option.default "" state.remote_port)
1043          (Option.default "" state.remote_directory)
1044          (match state.network with
1045           | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
1046           | Some Static -> "Static" | Some QEMUUserNet -> "QEMU user net"
1047           | None -> "")
1048          (String.concat "," (Option.default [] state.devices_to_send))
1049          (Option.map_default dev_of_partition "" state.root_filesystem)
1050          (match state.hypervisor with
1051           | Some Xen -> "Xen" | Some QEMU -> "QEMU" | Some KVM -> "KVM"
1052           | None -> "Other / not set")
1053          (match state.architecture with
1054           | Some UnknownArch -> "Auto-detect"
1055           | Some arch -> string_of_architecture arch | None -> "")
1056          (match state.memory with
1057           | Some 0 -> "Same as physical"
1058           | Some mem -> string_of_int mem ^ " MB" | None -> "")
1059          (match state.vcpus with
1060           | Some 0 -> "Same as physical"
1061           | Some vcpus -> string_of_int vcpus | None -> "")
1062          (match state.mac_address with
1063           | Some "" -> "Random" | Some mac -> mac | None -> "")
1064       )
1065       21 50
1066     with
1067     | Yes _ -> Next state
1068     | Back -> Prev
1069     | No | Help | Error -> Ask_again
1070   in
1071
1072   (* This is the list of dialogs, in order.  The user can go forwards or
1073    * backwards through them.
1074    *
1075    * The second parameter in each tuple is true if we need to skip
1076    * this dialog statically (info already supplied in 'defaults' above).
1077    *
1078    * The third parameter in each tuple is a function that tests whether
1079    * this dialog should be skipped, given other parts of the current state.
1080    *)
1081   let dlgs =
1082     let dont_skip _ = false in
1083     [|
1084     ask_greeting,      not defaults.greeting,             dont_skip;
1085     ask_hostname,      defaults.remote_host <> None,      dont_skip;
1086     ask_port,          defaults.remote_port <> None,      dont_skip;
1087     ask_directory,     defaults.remote_directory <> None, dont_skip;
1088     ask_username,      defaults.remote_username <> None,  dont_skip;
1089     ask_network,       defaults.network <> None,          dont_skip;
1090     ask_static_network_config,
1091       defaults.static_network_config <> None,
1092       (function { network = Some Static } -> false | _ -> true);
1093     ask_devices,       defaults.devices_to_send <> None,  dont_skip;
1094     ask_root,          defaults.root_filesystem <> None,  dont_skip;
1095     ask_hypervisor,    defaults.hypervisor <> None,       dont_skip;
1096     ask_architecture,  defaults.architecture <> None,     dont_skip;
1097     ask_memory,        defaults.memory <> None,           dont_skip;
1098     ask_vcpus,         defaults.vcpus <> None,            dont_skip;
1099     ask_mac_address,   defaults.mac_address <> None,      dont_skip;
1100     ask_verify,        not defaults.greeting,             dont_skip;
1101   |] in
1102
1103   (* Loop through the dialogs until we reach the end. *)
1104   let rec loop ?(back=false) posn state =
1105     eprintf "dialog loop: posn = %d, back = %b\n%!" posn back;
1106     if posn >= Array.length dlgs then state (* Finished all dialogs. *)
1107     else if posn < 0 then loop 0 state
1108     else (
1109       let dlg, skip_static, skip_dynamic = dlgs.(posn) in
1110       if skip_static || skip_dynamic state then
1111         (* Skip this dialog. *)
1112         loop ~back (if back then posn-1 else posn+1) state
1113       else (
1114         (* Run dialog. *)
1115         match dlg state with
1116         | Next new_state -> loop (posn+1) new_state (* Forwards. *)
1117         | Ask_again -> loop posn state  (* Repeat the question. *)
1118         | Prev -> loop ~back:true (posn-1) state (* Backwards / back button. *)
1119       )
1120     )
1121   in
1122   let state = loop 0 defaults in
1123
1124   eprintf "finished dialog loop\n%!";
1125
1126   (* Switch LVM config. *)
1127   sh "vgchange -a n";
1128   putenv "LVM_SYSTEM_DIR" "/etc/lvm.new"; (* see lvm(8) *)
1129   sh "rm -f /etc/lvm/cache/.cache";
1130   sh "rm -f /etc/lvm.new/cache/.cache";
1131
1132   (* Snapshot the block devices to send. *)
1133   let devices_to_send = Option.get state.devices_to_send in
1134   let devices_to_send =
1135     List.map (
1136       fun origin_dev ->
1137         let snapshot_dev = snapshot_name origin_dev in
1138         snapshot origin_dev snapshot_dev;
1139         (origin_dev, snapshot_dev)
1140     ) devices_to_send in
1141
1142   (* Run kpartx on the snapshots. *)
1143   List.iter (
1144     fun (origin, snapshot) ->
1145       shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
1146   ) devices_to_send;
1147
1148   (* Rescan for LVs. *)
1149   sh "vgscan";
1150   sh "vgchange -a y";
1151
1152   (* Mount the root filesystem under /mnt/root. *)
1153   let root_filesystem = Option.get state.root_filesystem in
1154   (match root_filesystem with
1155    | Part (dev, partnum) ->
1156        let dev = dev ^ partnum in
1157        let snapshot_dev = snapshot_name dev in
1158        sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
1159
1160    | LV (vg, lv) ->
1161        (* The LV will be backed by a snapshot device, so just mount
1162         * directly.
1163         *)
1164        sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
1165   );
1166
1167   (* See if we can do network configuration. *)
1168   let network = Option.get state.network in
1169   (match network with
1170    | Shell ->
1171        printf "Network configuration.\n\n";
1172        printf "Please configure the network from this shell.\n\n";
1173        printf "When you have finished, exit the shell with ^D or exit.\n\n%!";
1174        shell ()
1175
1176    | Static ->
1177        printf "Trying static network configuration.\n\n%!";
1178        if not (static_network state) then (
1179          printf "\nAuto-configuration failed.  Starting a shell.\n\n";
1180          printf "Please configure the network from this shell.\n\n";
1181          printf "When you have finished, exit the shell with ^D or exit.\n\n";
1182          shell ()
1183        )
1184
1185    | Auto ->
1186        printf
1187          "Trying network auto-configuration from root filesystem ...\n\n%!";
1188        if not (auto_network state) then (
1189          printf "\nAuto-configuration failed.  Starting a shell.\n\n";
1190          printf "Please configure the network from this shell.\n\n";
1191          printf "When you have finished, exit the shell with ^D or exit.\n\n";
1192          shell ()
1193        )
1194    | QEMUUserNet ->
1195        printf "Trying QEMU network configuration.\n\n%!";
1196        qemu_network ()
1197   );
1198
1199   (* Work out what devices will be called at the remote end. *)
1200   let devices_to_send = List.map (
1201     fun (origin_dev, snapshot_dev) ->
1202       let remote_dev = remote_of_origin_dev origin_dev in
1203       (origin_dev, snapshot_dev, remote_dev)
1204   ) devices_to_send in
1205
1206   (* Modify files on the root filesystem. *)
1207   rewrite_fstab state devices_to_send;
1208   (* XXX Other files to rewrite? *)
1209
1210   (* Unmount the root filesystem and sync disks. *)
1211   sh "umount /mnt/root";
1212   sh "sync";                            (* Ugh, should be in stdlib. *)
1213
1214   (* Get architecture of root filesystem, detected previously. *)
1215   let system_architecture =
1216     try
1217       (match List.assoc root_filesystem all_partitions with
1218        | LinuxRoot (arch, _) -> arch
1219        | _ -> raise Not_found
1220       )
1221     with
1222       Not_found ->
1223         (* None was detected before, so assume same as live CD. *)
1224         let arch = shget "uname -m" in
1225         match arch with
1226         | Some (("i386"|"i486"|"i586"|"i686")::_) -> I386
1227         | Some ("x86_64"::_) -> X86_64
1228         | Some ("ia64"::_) -> IA64
1229         | _ -> I386 (* probably wrong XXX *) in
1230
1231   (* Autodetect system memory. *)
1232   let system_memory =
1233     let mem = shget "head -1 /proc/meminfo | awk '{print $2/1024}'" in
1234     match mem with
1235     | Some (mem::_) -> int_of_float (float_of_string mem)
1236     | _ -> 256 in
1237
1238   (* Autodetect system # pCPUs. *)
1239   let system_nr_cpus =
1240     let cpus =
1241       shget "grep ^processor /proc/cpuinfo | tail -1 | awk '{print $3+1}'" in
1242     match cpus with
1243     | Some (cpus::_) -> int_of_string cpus
1244     | _ -> 1 in
1245
1246   let remote_host = Option.get state.remote_host in
1247   let remote_port = Option.get state.remote_port in
1248   let remote_directory = Option.get state.remote_directory in
1249   let remote_username = Option.get state.remote_username in
1250
1251   (* Functions to connect and disconnect from the remote system. *)
1252   let do_connect remote_name _ =
1253     let cmd = sprintf "ssh -C -l %s -p %s %s \"cat > %s/%s\""
1254       (quote remote_username) (quote remote_port) (quote remote_host)
1255       (quote remote_directory) (quote remote_name) in
1256     eprintf "connect: %s\n%!" cmd;
1257     let chan = open_process_out cmd in
1258     descr_of_out_channel chan, chan
1259   in
1260   let do_disconnect (_, chan) =
1261     match close_process_out chan with
1262     | WEXITED 0 -> ()           (* OK *)
1263     | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
1264     | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
1265     | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
1266   in
1267
1268   (* XXX This is using the hostname derived from network configuration
1269    * above.  We might want to ask the user to choose.
1270    *)
1271   let hostname = safe_name (gethostname ()) in
1272   let basename =
1273     let date = sprintf "%04d%02d%02d%02d%02d"
1274       (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
1275     "p2v-" ^ hostname ^ "-" ^ date in
1276
1277   (* Work out what the image filenames will be at the remote end. *)
1278   let devices_to_send = List.map (
1279     fun (origin_dev, snapshot_dev, remote_dev) ->
1280       let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
1281       (origin_dev, snapshot_dev, remote_dev, remote_name)
1282   ) devices_to_send in
1283
1284   (* Write a configuration file.  Not sure if this is any better than
1285    * just 'sprintf-ing' bits of XML text together, but at least we will
1286    * always get well-formed XML.
1287    *
1288    * XXX For some of the stuff here we really should do a
1289    * virConnectGetCapabilities call to the remote host first.
1290    *
1291    * XXX There is a case for using virt-install to generate this XML.
1292    * When we start to incorporate libvirt access & storage API this
1293    * needs to be rethought.
1294    *)
1295   let conf_filename = basename ^ ".conf" in
1296
1297   let architecture =
1298     match state.architecture with
1299     | Some UnknownArch | None -> system_architecture
1300     | Some arch -> arch in
1301   let memory =
1302     match state.memory with
1303     | Some 0 | None -> system_memory
1304     | Some memory -> memory in
1305   let vcpus =
1306     match state.vcpus with
1307     | Some 0 | None -> system_nr_cpus
1308     | Some n -> n in
1309   let mac_address =
1310     match state.mac_address with
1311     | Some "" | None -> random_mac_address ()
1312     | Some mac -> mac in
1313
1314   let xml =
1315     (* Shortcut to make "<name>value</name>". *)
1316     let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
1317     (* ... and the _other_ sort of leaf (god I hate XML). *)
1318     let tleaf name attribs = Xml.Element (name, attribs, []) in
1319
1320     (* Standard stuff for every domain. *)
1321     let name = leaf "name" hostname in
1322     let uuid = leaf "uuid" (random_uuid ()) in
1323     let maxmem = leaf "maxmem" (string_of_int (memory * 1024)) in
1324     let memory = leaf "memory" (string_of_int (memory * 1024)) in
1325     let vcpu = leaf "vcpu" (string_of_int vcpus) in
1326
1327     (* Top-level stuff which differs for each HV type (isn't this supposed
1328      * to be portable ...)
1329      *)
1330     let extras =
1331       match state.hypervisor with
1332       | Some Xen ->
1333           [Xml.Element ("os", [],
1334                         [leaf "type" "hvm";
1335                          leaf "loader" "/usr/lib/xen/boot/hvmloader";
1336                          tleaf "boot" ["dev", "hd"]]);
1337            Xml.Element ("features", [],
1338                         [tleaf "pae" [];
1339                          tleaf "acpi" [];
1340                          tleaf "apic" []]);
1341            tleaf "clock" ["sync", "localtime"]]
1342       | Some KVM ->
1343           [Xml.Element ("os", [], [leaf "type" "hvm"]);
1344            tleaf "clock" ["sync", "localtime"]]
1345       | Some QEMU ->
1346           [Xml.Element ("os", [],
1347                         [Xml.Element ("type",
1348                                       ["arch",
1349                                        string_of_architecture architecture;
1350                                        "machine","pc"],
1351                                       [Xml.PCData "hvm"]);
1352                          tleaf "boot" ["dev", "hd"]])]
1353       | None ->
1354           [] in
1355
1356     (* <devices> section. *)
1357     let devices =
1358       let emulator =
1359         match state.hypervisor with
1360         | Some Xen ->
1361             [leaf "emulator" "/usr/lib64/xen/bin/qemu-dm"] (* XXX lib64? *)
1362         | Some QEMU ->
1363             [leaf "emulator" "/usr/bin/qemu"]
1364         | Some KVM ->
1365             [leaf "emulator" "/usr/bin/qemu-kvm"]
1366         | None ->
1367             [] in
1368       let interface =
1369         Xml.Element ("interface", ["type", "user"],
1370                      [tleaf "mac" ["address", mac_address]]) in
1371       (* XXX should have an option for Xen bridging:
1372         Xml.Element (
1373         "interface", ["type","bridge"],
1374         [tleaf "source" ["bridge","xenbr0"];
1375         tleaf "mac" ["address",mac_address];
1376         tleaf "script" ["path","vif-bridge"]])*)
1377       let graphics = tleaf "graphics" ["type", "vnc"] in
1378
1379       let disks = List.map (
1380         fun (_, _, remote_dev, remote_name) ->
1381           Xml.Element (
1382             "disk", ["type", "file";
1383                      "device", "disk"],
1384             [tleaf "source" ["file", remote_directory ^ "/" ^ remote_name];
1385              tleaf "target" ["dev", remote_dev]]
1386           )
1387       ) devices_to_send in
1388
1389       Xml.Element (
1390         "devices", [],
1391         emulator @ interface :: graphics :: disks
1392       ) in
1393
1394     (* Put it all together in <domain type='foo'>. *)
1395     Xml.Element (
1396       "domain",
1397       (match state.hypervisor with
1398        | Some Xen -> ["type", "xen"]
1399        | Some QEMU -> ["type", "qemu"]
1400        | Some KVM -> ["type", "kvm"]
1401        | None -> []),
1402       name :: uuid :: memory :: maxmem :: vcpu :: extras @ [devices]
1403     ) in
1404
1405   (* Convert XML configuration file to a string, then send it to the
1406    * remote server.
1407    *)
1408   let () =
1409     let xml = Xml.to_string_fmt xml in
1410
1411     let conn_arg =
1412       match state.hypervisor with
1413       | Some Xen | None -> ""
1414       | Some QEMU | Some KVM -> " -c qemu:///system" in
1415     let xml = sprintf "\
1416 <!--
1417   This is a libvirt configuration file.
1418
1419   To start the domain, do:
1420     virsh%s define %s
1421     virsh%s start %s
1422 -->\n\n" conn_arg conf_filename conn_arg hostname ^ xml in
1423
1424     let xml_len = String.length xml in
1425     eprintf "length of configuration file is %d bytes\n%!" xml_len;
1426
1427     let (sock,_) as conn = do_connect conf_filename (Int64.of_int xml_len) in
1428     (* In OCaml this actually loops calling write(2) *)
1429     ignore (write sock xml 0 xml_len);
1430     do_disconnect conn in
1431
1432   (* Send the device snapshots to the remote host. *)
1433   (* XXX This code should be made more robust against both network
1434    * errors and local I/O errors.  Also should allow the user several
1435    * attempts to connect, or let them go back to the dialog stage.
1436    *)
1437   List.iter (
1438     fun (origin_dev, snapshot_dev, remote_dev, remote_name) ->
1439       eprintf "sending %s as %s\n%!" origin_dev remote_name;
1440
1441       let size =
1442         try List.assoc origin_dev all_block_devices
1443         with Not_found -> assert false (* internal error *) in
1444
1445       printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
1446         ((Int64.to_float size) /. (1024.*.1024.*.1024.));
1447
1448       (* Open the snapshot device. *)
1449       let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
1450
1451       (* Now connect. *)
1452       let (sock,_) as conn = do_connect remote_name size in
1453
1454       (* Copy the data. *)
1455       let bufsize = 1024 * 1024 in
1456       let buffer = String.create bufsize in
1457       let start = gettimeofday () in
1458
1459       let rec copy bytes_sent last_printed_at =
1460         let n = read fd buffer 0 bufsize in
1461         if n > 0 then (
1462           ignore (write sock buffer 0 n);
1463
1464           let bytes_sent = Int64.add bytes_sent (Int64.of_int n) in
1465           let last_printed_at =
1466             let now = gettimeofday () in
1467             (* Print progress every few seconds. *)
1468             if now -. last_printed_at > 5. then (
1469               let elapsed = Int64.to_float bytes_sent /. Int64.to_float size in
1470               let secs_elapsed = now -. start in
1471               printf "%.0f%%" (100. *. elapsed);
1472               (* After 60 seconds has elapsed, start printing estimates. *)
1473               if secs_elapsed >= 60. then (
1474                 let remaining = 1. -. elapsed in
1475                 let secs_remaining = (remaining /. elapsed) *. secs_elapsed in
1476                 if secs_remaining > 120. then
1477                   printf " (about %.0f minutes remaining)          "
1478                     (secs_remaining /. 60.)
1479                 else
1480                   printf " (about %.0f seconds remaining)          "
1481                     secs_remaining
1482               );
1483               printf "\r%!";
1484               now
1485             )
1486             else last_printed_at in
1487
1488           copy bytes_sent last_printed_at
1489         )
1490       in
1491       copy 0L start;
1492
1493       (* Disconnect. *)
1494       do_disconnect conn
1495   ) devices_to_send;
1496
1497   (* Clean up and reboot. *)
1498   ignore (
1499     msgbox "virt-p2v completed"
1500       (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."
1501          remote_directory conf_filename)
1502       17 50
1503   );
1504
1505   shfailok "eject";
1506   shfailok "reboot";
1507   exit 0
1508
1509 let usage () =
1510   eprintf "usage: virt-p2v [--test] [ttyname]\n%!";
1511   exit 2
1512
1513 (* Make sure that exceptions from 'main' get printed out on stdout
1514  * as well as stderr, since stderr is probably redirected to the
1515  * logfile, and so not visible to the user.
1516  *)
1517 let handle_exn f arg =
1518   try f arg
1519   with exn -> print_endline (Printexc.to_string exn); raise exn
1520
1521 (* Test harness for the Makefile.  The Makefile invokes this script as
1522  * 'virt-p2v --test' just to check it compiles.  When it is running
1523  * from the actual live CD, there is a single parameter which is the
1524  * tty name (so usually 'virt-p2v tty1').
1525  *)
1526 let () =
1527   match Array.to_list Sys.argv with
1528   | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
1529   | [ _; "--test" ] -> ()               (* Makefile test - do nothing. *)
1530   | [ _; ttyname ] ->                   (* Run main with ttyname. *)
1531       handle_exn main (Some ttyname)
1532   | [ _ ] ->                            (* Interactive - no ttyname. *)
1533       handle_exn main None
1534   | _ -> usage ()
1535
1536 (* This file must end with a newline *)