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