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
   8 (* virt-p2v.ml is a script which performs a physical to
   9  * virtual conversion of local disks.
  10  *
  11  * Copyright (C) 2007-2008 Red Hat Inc.
  12  * Written by Richard W.M. Jones <rjones@redhat.com>
  13  *
  14  * This program is free software; you can redistribute it and/or modify
  15  * it under the terms of the GNU General Public License as published by
  16  * the Free Software Foundation; either version 2 of the License, or
  17  * (at your option) any later version.
  18  *
  19  * This program is distributed in the hope that it will be useful,
  20  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  21  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22  * GNU General Public License for more details.
  23  *
  24  * You should have received a copy of the GNU General Public License
  25  * along with this program; if not, write to the Free Software
  26  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  27  *)
  28
  29 open Unix
  30 open Printf
  31 open ExtList
  32 open ExtString
  33
  34 type state = { greeting : bool;
  35                remote_host : string option; remote_port : string option;
  36                transport : transport option;
  37                remote_directory : string option;
  38                network : network option;
  39                devices_to_send : string list option;
  40                root_filesystem : partition option }
  41 and transport = Server | SSH | TCP
  42 and network = Auto | Shell
  43 and partition = Part of string * string (* eg. "hda", "1" *)
  44               | LV of string * string   (* eg. "VolGroup00", "LogVol00" *)
  45
  46 (*----------------------------------------------------------------------*)
  47 (* TO MAKE A CUSTOM virt-p2v SCRIPT, adjust the defaults in this section.
  48  *
  49  * If left as they are, then this will create a generic virt-p2v script
  50  * which asks the user for each question.  If you set the defaults here
  51  * then you will get a custom virt-p2v which is partially or even fully
  52  * automated and won't ask the user any questions.
  53  *
  54  * Note that 'None' means 'no default' (ie. ask the user) whereas
  55  * 'Some foo' means use 'foo' as the answer.
  56  *)
  57 let defaults = {
  58   (* If greeting is true, wait for keypress after boot and during
  59    * final verification.  Set to 'false' for less interactions.
  60    *)
  61   greeting = true;
  62
  63   (* Transport: Set to 'Some Server' or 'Some SSH' or 'Some TCP' to
  64    * assume Server, SSH or TCP transports respectively.
  65    *)
  66   transport = None;
  67
  68   (* Remote host and port.  Set to 'Some "host"' and 'Some "port"',
  69    * else ask the user.
  70    *)
  71   remote_host = None;
  72   remote_port = None;
  73
  74   (* Remote directory (only for SSH transport).  Set to 'Some "path"'
  75    * to set up a directory path, else ask the user.
  76    *)
  77   remote_directory = None;
  78
  79   (* List of devices to send.  Set to 'Some ["sda"; "sdb"]' for
  80    * example to select /dev/sda and /dev/sdb.
  81    *)
  82   devices_to_send = None;
  83
  84   (* The root filesystem containing /etc/fstab.  Set to
  85    * 'Some (Part ("sda", "3"))' or 'Some (LV ("VolGroup00", "LogVol00"))'
  86    * for example, else ask user.
  87    *)
  88   root_filesystem = None;
  89
  90   (* Network configuration: Set to 'Some Auto' (try to set it up
  91    * automatically, or 'Some Shell' (give the user a shell).
  92    *)
  93   network = None;
  94 }
  95 (* END OF CUSTOM virt-p2v SCRIPT SECTION.                               *)
  96 (*----------------------------------------------------------------------*)
  97
  98 (* General helper functions. *)
  99
 100 let sort_uniq ?(cmp = compare) xs =     (* sort and uniq a list *)
 101   let xs = List.sort ~cmp xs in
 102   let rec loop = function
 103     | [] -> [] | [x] -> [x]
 104     | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
 105     | x :: xs -> x :: loop xs
 106   in
 107   loop xs
 108
 109 let input_all_lines chan =
 110   let lines = ref [] in
 111   try
 112     while true do lines := input_line chan :: !lines done; []
 113   with
 114     End_of_file -> List.rev !lines
 115
 116 let rec string_of_state state =
 117   sprintf
 118     "greeting: %b  remote: %s:%s%s%s  network: %s  devices: [%s]  root: %s"
 119     state.greeting
 120     (Option.default "" state.remote_host)
 121     (Option.default "" state.remote_port)
 122     (match state.transport with
 123      | None -> ""
 124      | Some Server -> " (server)" | Some SSH -> " (ssh)" | Some TCP -> " (tcp)")
 125     (match state.remote_directory with
 126      | None -> "" | Some dir -> " " ^ dir)
 127     (match state.network with
 128      | None -> "none" | Some Auto -> "auto" | Some Shell -> "shell")
 129     (String.concat "; " (Option.default [] state.devices_to_send))
 130     (Option.map_default dev_of_partition "" state.root_filesystem)
 131
 132 and dev_of_partition = function
 133   | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
 134   | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
 135
 136 type dialog_status = Yes of string list | No | Help | Back | Error
 137
 138 type ask_result = Next of state | Prev | Ask_again
 139
 140 (* Dialog functions.
 141  *
 142  * Each function takes some common parameters (eg. ~title) and some
 143  * dialog-specific parameters.
 144  *
 145  * Returns the exit status (Yes lines | No | Help | Back | Error).
 146  *)
 147 let msgbox, yesno, inputbox, radiolist, checklist =
 148   (* Internal function to actually run the "dialog" shell command. *)
 149   let run_dialog cparams params =
 150     let params = cparams @ params in
 151     eprintf "dialog %s\n%!"
 152       (String.concat " " (List.map (sprintf "%S") params));
 153
 154     (* 'dialog' writes its output/result to stderr, so we need to take
 155      * special steps to capture that - in other words, manual pipe/fork.
 156      *)
 157     let rfd, wfd = pipe () in
 158     match fork () with
 159     | 0 ->                              (* child, runs dialog *)
 160         close rfd;
 161         dup2 wfd stderr;                (* capture stderr to pipe *)
 162         execvp "dialog" (Array.of_list ("dialog" :: params))
 163     | pid ->                            (* parent *)
 164         close wfd;
 165         let chan = in_channel_of_descr rfd in
 166         let result = input_all_lines chan in
 167         close rfd;
 168         eprintf "dialog result: %S\n%!" (String.concat "\n" result);
 169         match snd (wait ()) with
 170         | WEXITED 0 -> Yes result       (* something selected / entered *)
 171         | WEXITED 1 -> No               (* cancel / no button *)
 172         | WEXITED 2 -> Help             (* help pressed *)
 173         | WEXITED 3 -> Back             (* back button *)
 174         | WEXITED _ -> Error            (* error or Esc *)
 175         | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
 176         | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
 177   in
 178
 179   (* Handle the common parameters.  Note Continuation Passing Style. *)
 180   let with_common cont ?(cancel=false) ?(backbutton=true) title =
 181     let params = ["--title"; title] in
 182     let params = if not cancel then "--nocancel" :: params else params in
 183     let params =
 184       if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
 185       else params in
 186     cont params
 187   in
 188
 189   (* Message box and yes/no box. *)
 190   let rec msgbox =
 191     with_common (
 192       fun cparams text height width ->
 193         run_dialog cparams
 194           [ "--msgbox"; text; string_of_int height; string_of_int width ]
 195     )
 196   and yesno =
 197     with_common (
 198       fun cparams text height width ->
 199         run_dialog cparams
 200           [ "--yesno"; text; string_of_int height; string_of_int width ]
 201     )
 202
 203   (* Simple input box. *)
 204   and inputbox =
 205     with_common (
 206       fun cparams text height width default ->
 207         run_dialog cparams
 208           [ "--inputbox"; text; string_of_int height; string_of_int width;
 209             default ]
 210     )
 211
 212   (* Radio list and check list. *)
 213   and radiolist =
 214     with_common (
 215       fun cparams text height width listheight items ->
 216         let items = List.map (
 217           function
 218           | tag, item, true -> [ tag; item; "on" ]
 219           | tag, item, false -> [ tag; item; "off" ]
 220         ) items in
 221         let items = List.concat items in
 222         let items = "--single-quoted" ::
 223           "--radiolist" :: text ::
 224           string_of_int height :: string_of_int width ::
 225           string_of_int listheight :: items in
 226         run_dialog cparams items
 227     )
 228   and checklist =
 229     with_common (
 230       fun cparams text height width listheight items ->
 231         let items = List.map (
 232           function
 233           | tag, item, true -> [ tag; item; "on" ]
 234           | tag, item, false -> [ tag; item; "off" ]
 235         ) items in
 236         let items = List.concat items in
 237         let items = "--separate-output" ::
 238           "--checklist" :: text ::
 239           string_of_int height :: string_of_int width ::
 240           string_of_int listheight :: items in
 241         run_dialog cparams items
 242     )
 243   in
 244   msgbox, yesno, inputbox, radiolist, checklist
 245
 246 (* Print failure dialog and exit. *)
 247 let fail_dialog text =
 248   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
 249   ignore (msgbox "Error" text 17 50);
 250   exit 1
 251
 252 (* Shell-safe quoting function.  In fact there's one in stdlib so use it. *)
 253 let quote = Filename.quote
 254
 255 (* Run a shell command and check it returns 0. *)
 256 let sh cmd =
 257   eprintf "sh: %s\n%!" cmd;
 258   if Sys.command cmd <> 0 then fail_dialog (sprintf "Command failed:\n\n%s" cmd)
 259
 260 let shfailok cmd =
 261   eprintf "shfailok: %s\n%!" cmd;
 262   ignore (Sys.command cmd)
 263
 264 let shwithstatus cmd =
 265   eprintf "shfailok: %s\n%!" cmd;
 266   Sys.command cmd
 267
 268 (* Same as `cmd` in shell.  Any error message will be in the logfile. *)
 269 let shget cmd =
 270   eprintf "shget: %s\n%!" cmd;
 271   let chan = open_process_in cmd in
 272   let lines = input_all_lines chan in
 273   match close_process_in chan with
 274   | WEXITED 0 -> Some lines             (* command succeeded *)
 275   | WEXITED _ -> None                   (* command failed *)
 276   | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
 277   | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
 278
 279 (* Start an interactive shell. *)
 280 let shell () =
 281   shfailok "PS1='\\u@\\h:\\w\\$ ' bash"
 282
 283 (* Some true if is dir/file, Some false if not, None if not found. *)
 284 let is_dir path =
 285   try Some ((stat path).st_kind = S_DIR)
 286   with Unix_error (ENOENT, "stat", _) -> None
 287 let is_file path =
 288   try Some ((stat path).st_kind = S_REG)
 289   with Unix_error (ENOENT, "stat", _) -> None
 290
 291 (* Useful regular expression. *)
 292 let whitespace = Pcre.regexp "[ \t]+"
 293
 294 (* Generate a predictable safe name containing only letters, numbers
 295  * and underscores.  If passed a string with no letters or numbers,
 296  * generates "_1", "_2", etc.
 297  *)
 298 let safe_name =
 299   let next_anon =
 300     let i = ref 0 in
 301     fun () -> incr i; "_" ^ string_of_int !i
 302   in
 303   fun name ->
 304     let is_safe = function 'a'..'z'|'A'..'Z'|'0'..'9' -> true | _ -> false in
 305     let name = String.copy name in
 306     let have_safe = ref false in
 307     for i = 0 to String.length name - 1 do
 308       if not (is_safe name.[i]) then name.[i] <- '_' else have_safe := true
 309     done;
 310     if !have_safe then name else next_anon ()
 311
 312 type block_device = string * int64      (* "hda" & size in bytes *)
 313
 314 (* Parse the output of 'lvs' to get list of LV names, sizes,
 315  * corresponding PVs, etc.  Returns a list of (lvname, PVs, lvsize).
 316  *)
 317 let get_lvs =
 318   let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
 319
 320   function () ->
 321     match
 322     shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
 323     with
 324     | None -> []
 325     | Some lines ->
 326         let lines = List.map (Pcre.split ~rex:whitespace) lines in
 327         List.map (
 328           function
 329           | [vg; lv; pvs; lvsize]
 330           | [_; vg; lv; pvs; lvsize] ->
 331               let pvs = String.nsplit "," pvs in
 332               let pvs = List.map (
 333                 fun pv ->
 334                   try
 335                     let subs = Pcre.exec ~rex:devname pv in
 336                     Pcre.get_substring subs 1
 337                   with
 338                     Not_found -> failwith ("lvs: unexpected device name: " ^ pv)
 339               ) pvs in
 340               LV (vg, lv), pvs, lvsize
 341           | line ->
 342               failwith ("lvs: unexpected output: " ^ String.concat "," line)
 343         ) lines
 344
 345 (* Get the partitions on a block device.
 346  * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
 347  *)
 348 let get_partitions dev =
 349   let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
 350   let devdir = "/sys/block/" ^ dev in
 351   let parts = Sys.readdir devdir in
 352   let parts = Array.to_list parts in
 353   let parts = List.filter (
 354     fun name -> Some true = is_dir (devdir ^ "/" ^ name)
 355   ) parts in
 356   let parts = List.filter_map (
 357     fun part ->
 358       try
 359         let subs = Pcre.exec ~rex part in
 360         Some (Part (dev, Pcre.get_substring subs 1))
 361       with
 362         Not_found -> None
 363   ) parts in
 364   parts
 365
 366 (* Generate snapshot device name from device name. *)
 367 let snapshot_name dev =
 368   "snap" ^ (safe_name dev)
 369
 370 (* Perform a device-mapper snapshot with ramdisk overlay. *)
 371 let snapshot =
 372   let next_free_ram_disk =
 373     let i = ref 0 in
 374     fun () -> incr i; "/dev/ram" ^ string_of_int !i
 375   in
 376   fun origin_dev snapshot_dev ->
 377     let ramdisk = next_free_ram_disk () in
 378     let sectors =
 379       let cmd = "blockdev --getsz " ^ quote ("/dev/" ^ origin_dev) in
 380       let lines = shget cmd in
 381       match lines with
 382       | Some (sectors::_) -> Int64.of_string sectors
 383       | Some [] | None ->
 384           fail_dialog (sprintf "Snapshot failed - unable to read the size in sectors of block device %s" origin_dev) in
 385
 386     (* Create the snapshot origin device.  Called, eg. snap_sda1_org *)
 387     sh (sprintf "dmsetup create %s_org --table='0 %Ld snapshot-origin /dev/%s'"
 388           snapshot_dev sectors origin_dev);
 389     (* Create the snapshot. *)
 390     sh (sprintf "dmsetup create %s --table='0 %Ld snapshot /dev/mapper/%s_org %s n 64'"
 391           snapshot_dev sectors snapshot_dev ramdisk)
 392
 393 (* Try to perform automatic network configuration, assuming a Fedora or RHEL-
 394  * like root filesystem mounted on /mnt/root.
 395  *)
 396 let auto_network state =
 397   (* Fedora gives an error if this file doesn't exist. *)
 398   sh "touch /etc/resolv.conf";
 399
 400   chdir "/etc/sysconfig";
 401
 402   sh "mv network network.saved";
 403   sh "mv networking networking.saved";
 404   sh "mv network-scripts network-scripts.saved";
 405
 406   (* Originally I symlinked these, but that causes dhclient to
 407    * keep open /mnt/root (as its cwd is in network-scripts subdir).
 408    * So now we will copy them recursively instead.
 409    *)
 410   sh "cp -r /mnt/root/etc/sysconfig/network .";
 411   sh "cp -r /mnt/root/etc/sysconfig/networking .";
 412   sh "cp -r /mnt/root/etc/sysconfig/network-scripts .";
 413
 414   let status = shwithstatus "/etc/init.d/network start" in
 415
 416   sh "rm -rf network networking network-scripts";
 417   sh "mv network.saved network";
 418   sh "mv networking.saved networking";
 419   sh "mv network-scripts.saved network-scripts";
 420
 421   chdir "/tmp";
 422
 423   (* Try to ping the remote host to see if this worked. *)
 424   sh ("ping -c 3 " ^ Option.map_default quote "" state.remote_host);
 425
 426   if state.greeting then (
 427     printf "\n\nDid automatic network configuration work?\n";
 428     printf "Hint: If not sure, there is a shell on console [ALT] [F2]\n";
 429     printf "    (y/n) %!";
 430     let line = read_line () in
 431     String.length line > 0 && (line.[0] = 'y' || line.[0] = 'Y')
 432   )
 433   else
 434     (* Non-interactive: return the status of /etc/init.d/network start. *)
 435     status = 0
 436
 437 (* Map local device names to remote devices names.  At the moment we
 438  * just change sd* to hd* (as device names appear under fullvirt).  In
 439  * future, lots of complex possibilities.
 440  *)
 441 let remote_of_origin_dev =
 442   let devsd = Pcre.regexp "^sd([[:alpha:]]+[[:digit:]]+)$" in
 443   let devsd_subst = Pcre.subst "hd$1" in
 444   fun dev ->
 445     Pcre.replace ~rex:devsd ~itempl:devsd_subst dev
 446
 447 (* Rewrite /mnt/root/etc/fstab. *)
 448 let rewrite_fstab state devices_to_send =
 449   let filename = "/mnt/root/etc/fstab" in
 450   if is_file filename = Some true then (
 451     sh ("cp " ^ quote filename ^ " " ^ quote (filename ^ ".p2vsaved"));
 452
 453     let chan = open_in filename in
 454     let lines = input_all_lines chan in
 455     close_in chan;
 456     let lines = List.map (Pcre.split ~rex:whitespace) lines in
 457     let lines = List.map (
 458       function
 459       | dev :: rest when String.starts_with dev "/dev/" ->
 460           let dev = String.sub dev 5 (String.length dev - 5) in
 461           let dev = remote_of_origin_dev dev in
 462           let dev = "/dev/" ^ dev in
 463           dev :: rest
 464       | line -> line
 465     ) lines in
 466
 467     let chan = open_out filename in
 468     List.iter (
 469       function
 470       | [dev; mountpoint; fstype; options; freq; passno] ->
 471           fprintf chan "%-23s %-23s %-7s %-15s %s %s\n"
 472             dev mountpoint fstype options freq passno
 473       | line ->
 474           output_string chan (String.concat " " line)
 475     ) lines;
 476     close_out chan
 477   )
 478
 479 (* Main entry point. *)
 480 let rec main ttyname =
 481   (* Running from an init script.  We don't have much of a
 482    * login environment, so set one up.
 483    *)
 484   putenv "PATH"
 485     (String.concat ":"
 486        ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
 487         "/usr/bin"; "/bin"]);
 488   putenv "HOME" "/root";
 489   putenv "LOGNAME" "root";
 490
 491   (* We can safely write in /tmp (it's a synthetic live CD directory). *)
 492   chdir "/tmp";
 493
 494   (* Set up logging to /tmp/virt-p2v.log. *)
 495   let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
 496   dup2 fd stderr;
 497   close fd;
 498
 499   (* Log the start up time. *)
 500   eprintf "\n\n**************************************************\n\n";
 501   let tm = localtime (time ()) in
 502   eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
 503     (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
 504
 505   (* Connect stdin/stdout to the tty. *)
 506   (match ttyname with
 507    | None -> ()
 508    | Some ttyname ->
 509        let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
 510        dup2 fd stdin;
 511        dup2 fd stdout;
 512        close fd);
 513
 514   (* Search for all non-removable block devices.  Do this early and bail
 515    * if we can't find anything.  This is a list of strings, like "hda".
 516    *)
 517   let all_block_devices : block_device list =
 518     let rex = Pcre.regexp "^[hs]d" in
 519     let devices = Array.to_list (Sys.readdir "/sys/block") in
 520     let devices = List.sort devices in
 521     let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
 522     eprintf "all_block_devices: block devices: %s\n%!"
 523       (String.concat "; " devices);
 524     (* Run blockdev --getsize64 on each, and reject any where this fails
 525      * (probably removable devices).
 526      *)
 527     let devices = List.filter_map (
 528       fun d ->
 529         let cmd = "blockdev --getsize64 " ^ quote ("/dev/" ^ d) in
 530         let lines = shget cmd in
 531         match lines with
 532         | Some (blksize::_) -> Some (d, Int64.of_string blksize)
 533         | Some [] | None -> None
 534     ) devices in
 535     eprintf "all_block_devices: non-removable block devices: %s\n%!"
 536       (String.concat "; "
 537          (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
 538     if devices = [] then
 539       fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
 540     devices in
 541
 542   (* Search for partitions and LVs (anything that could contain a
 543    * filesystem directly).  We refer to these generically as
 544    * "partitions".
 545    *)
 546   let all_partitions : partition list =
 547     (* LVs & PVs. *)
 548     let lvs, pvs =
 549       let lvs = get_lvs () in
 550       let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
 551       let pvs = List.concat pvs in
 552       let pvs = sort_uniq pvs in
 553       eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
 554       let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
 555       eprintf "all_partitions: LVs: %s\n%!"
 556         (String.concat "; " (List.map dev_of_partition lvs));
 557       lvs, pvs in
 558
 559     (* Partitions (eg. "sda1", "sda2"). *)
 560     let parts =
 561       let parts = List.map fst all_block_devices in
 562       let parts = List.map get_partitions parts in
 563       let parts = List.concat parts in
 564       eprintf "all_partitions: all partitions: %s\n%!"
 565         (String.concat "; " (List.map dev_of_partition parts));
 566
 567       (* Remove any partitions which are PVs. *)
 568       let parts = List.filter (
 569         function
 570         | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
 571         | LV _ -> assert false
 572       ) parts in
 573       parts in
 574     eprintf "all_partitions: partitions after removing PVs: %s\n%!"
 575       (String.concat "; " (List.map dev_of_partition parts));
 576
 577     (* Concatenate LVs & Parts *)
 578     lvs @ parts in
 579
 580   (* Dialogs. *)
 581   let ask_greeting state =
 582     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);
 583     Next state
 584   in
 585
 586   let ask_transport state =
 587     match
 588     radiolist "Connection type" ~backbutton:false
 589       "Connection type.  If possible, select 'server' and run P2V server on the remote host"
 590       10 50 2 [
 591         "server", "P2V server on remote host",
 592           state.transport = Some Server;
 593         "ssh", "SSH (secure shell)",
 594           state.transport = Some SSH;
 595         "tcp", "TCP socket",
 596           state.transport = Some TCP
 597       ]
 598     with
 599     | Yes ("server"::_) -> Next { state with transport = Some Server }
 600     | Yes ("ssh"::_) -> Next { state with transport = Some SSH }
 601     | Yes ("tcp"::_) -> Next { state with transport = Some TCP }
 602     | Yes _ | No | Help | Error -> Ask_again
 603     | Back -> Prev
 604   in
 605
 606   let ask_hostname state =
 607     match
 608     inputbox "Remote host" "Remote host" 10 50
 609       (Option.default "" state.remote_host)
 610     with
 611     | Yes [] -> Ask_again
 612     | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
 613     | No | Help | Error -> Ask_again
 614     | Back -> Prev
 615   in
 616
 617   let ask_port state =
 618     match
 619     inputbox "Remote port" "Remote port" 10 50
 620       (Option.default "" state.remote_port)
 621     with
 622     | Yes [] ->
 623         (match state.transport with
 624          | Some SSH -> Next { state with remote_port = Some "22" }
 625          | _ -> Next { state with remote_port = Some "16211" }
 626         )
 627     | Yes (port::_) -> Next { state with remote_port = Some port }
 628     | No | Help | Error -> Ask_again
 629     | Back -> Prev
 630   in
 631
 632   let ask_directory state =
 633     match
 634     inputbox "Remote directory" "Remote directory" 10 50
 635       (Option.default "" state.remote_directory)
 636     with
 637     | Yes [] ->
 638         Next { state with remote_directory = Some "/var/lib/xen/images" }
 639     | Yes (dir::_) -> Next { state with remote_directory = Some dir }
 640     | No | Help | Error -> Ask_again
 641     | Back -> Prev
 642   in
 643
 644   let ask_network state =
 645     match
 646     radiolist "Network configuration" "Network configuration" 10 50 2 [
 647       "auto", "Automatic configuration", state.network = Some Auto;
 648       "sh", "Configure from the shell", state.network = Some Shell;
 649     ]
 650     with
 651     | Yes ("auto"::_) -> Next { state with network = Some Auto }
 652     | Yes ("sh"::_) -> Next { state with network = Some Shell }
 653     | Yes _ | No | Help | Error -> Ask_again
 654     | Back -> Prev
 655   in
 656
 657   let ask_devices state =
 658     let selected_devices = Option.default [] state.devices_to_send in
 659     let devices = List.map (
 660       fun (dev, blksize) ->
 661         (dev,
 662          sprintf "/dev/%s (%.3f GB)" dev
 663            ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
 664          List.mem dev selected_devices)
 665     ) all_block_devices in
 666     match
 667     checklist "Devices" "Pick devices to send" 15 50 8 devices
 668     with
 669     | Yes [] | No | Help | Error -> Ask_again
 670     | Yes devices -> Next { state with devices_to_send = Some devices }
 671     | Back -> Prev
 672   in
 673
 674   let ask_root state =
 675     let parts = List.mapi (
 676       fun i part ->
 677         (string_of_int i, dev_of_partition part,
 678          Some part = state.root_filesystem)
 679     ) all_partitions in
 680     match
 681     radiolist "Root device"
 682       "Pick partition containing the root (/) filesystem" 15 50 6
 683       parts
 684     with
 685     | Yes (i::_) ->
 686         let part = List.nth all_partitions (int_of_string i) in
 687         Next { state with root_filesystem = Some part }
 688     | Yes [] | No | Help | Error -> Ask_again
 689     | Back -> Prev
 690   in
 691
 692   let ask_verify state =
 693     match
 694     yesno "Verify and proceed"
 695       (sprintf "\nPlease verify the settings below and click [OK] to proceed, or the [Back] button to return to a previous step.
 696
 697 Connection:   %s
 698 Remote host:  %s
 699 Remote port:  %s
 700 Directory:    %s
 701 Network:      %s
 702 Send devices: %s
 703 Root (/) dev: %s"
 704          (match state.transport with
 705           | Some Server -> "Server"
 706           | Some SSH -> "SSH" | Some TCP -> "TCP socket"
 707           | None -> "")
 708          (Option.default "" state.remote_host)
 709          (Option.default "" state.remote_port)
 710          (Option.default "" state.remote_directory)
 711          (match state.network with
 712           | Some Auto -> "Auto-configure" | Some Shell -> "Shell"
 713           | None -> "")
 714          (String.concat "," (Option.default [] state.devices_to_send))
 715          (Option.map_default dev_of_partition "" state.root_filesystem))
 716       18 50
 717     with
 718     | Yes _ -> Next state
 719     | Back -> Prev
 720     | No | Help | Error -> Ask_again
 721   in
 722
 723   (* This is the list of dialogs, in order.  The user can go forwards or
 724    * backwards through them.  The second parameter in each pair is
 725    * false if we need to skip this dialog (info already supplied in
 726    * 'defaults' above).
 727    *)
 728   let dlgs = [|
 729     ask_greeting,                       (* Initial greeting. *)
 730       defaults.greeting;
 731     ask_transport,                      (* Transport (ssh, tcp) *)
 732       defaults.transport = None;
 733     ask_hostname,                       (* Hostname. *)
 734       defaults.remote_host = None;
 735     ask_port,                           (* Port number. *)
 736       defaults.remote_port = None;
 737     ask_directory,                      (* Remote directory. *)
 738       defaults.remote_directory = None;
 739     ask_network,                        (* Network configuration. *)
 740       defaults.network = None;
 741     ask_devices,                        (* Block devices to send. *)
 742       defaults.devices_to_send = None;
 743     ask_root,                           (* Root filesystem. *)
 744       defaults.root_filesystem = None;
 745     ask_verify,                         (* Verify settings. *)
 746       defaults.greeting
 747   |] in
 748
 749   (* Loop through the dialogs until we reach the end. *)
 750   let rec loop posn state =
 751     eprintf "dialog loop: posn = %d\n%!" posn;
 752     if posn >= Array.length dlgs then state (* Finished all dialogs. *)
 753     else (
 754       let dlg, no_skip = dlgs.(posn) in
 755       let skip = not no_skip in
 756       if skip then
 757         (* Skip this dialog and move straight to the next one. *)
 758         loop (posn+1) state
 759       else (
 760         (* Run dialog. *)
 761         match dlg state with
 762         | Next new_state -> loop (posn+1) new_state (* Forwards. *)
 763         | Prev -> loop (posn-1) state       (* Backwards / back button. *)
 764         | Ask_again -> loop posn state      (* Repeat the question. *)
 765       )
 766     )
 767   in
 768   let state = loop 0 defaults in
 769
 770   eprintf "finished dialog loop\nfinal state = %s\n%!" (string_of_state state);
 771
 772   (* Check that the environment is a sane-looking live CD.  If not, bail. *)
 773   if is_dir "/mnt/root" <> Some true ||
 774      is_file "/etc/lvm/lvm.conf.new" <> Some true then
 775     fail_dialog "You should only run this script from the live CD or a USB key.";
 776
 777   (* Switch LVM config. *)
 778   sh "vgchange -a n";
 779   sh "mv /etc/lvm/lvm.conf /etc/lvm/lvm.conf.old";
 780   sh "mv /etc/lvm/lvm.conf.new /etc/lvm/lvm.conf";
 781   sh "rm -f /etc/lvm/cache/.cache";
 782
 783   (* Snapshot the block devices to send. *)
 784   let devices_to_send = Option.get state.devices_to_send in
 785   let devices_to_send =
 786     List.map (
 787       fun origin_dev ->
 788         let snapshot_dev = snapshot_name origin_dev in
 789         snapshot origin_dev snapshot_dev;
 790         (origin_dev, snapshot_dev)
 791     ) devices_to_send in
 792
 793   (* Run kpartx on the snapshots. *)
 794   List.iter (
 795     fun (origin, snapshot) ->
 796       shfailok ("kpartx -a " ^ quote ("/dev/mapper/" ^ snapshot))
 797   ) devices_to_send;
 798
 799   (* Rescan for LVs. *)
 800   sh "vgscan";
 801   sh "vgchange -a y";
 802
 803   (* Mount the root filesystem under /mnt/root. *)
 804   let root_filesystem = Option.get state.root_filesystem in
 805   (match root_filesystem with
 806    | Part (dev, partnum) ->
 807        let dev = dev ^ partnum in
 808        let snapshot_dev = snapshot_name dev in
 809        sh ("mount " ^ quote ("/dev/mapper/" ^ snapshot_dev) ^ " /mnt/root")
 810
 811    | LV (vg, lv) ->
 812        (* The LV will be backed by a snapshot device, so just mount directly. *)
 813        sh ("mount " ^ quote ("/dev/" ^ vg ^ "/" ^ lv) ^ " /mnt/root")
 814   );
 815
 816   (* See if we can do network configuration. *)
 817   let network = Option.get state.network in
 818   (match network with
 819    | Shell ->
 820        printf "Network configuration.\n\n";
 821        printf "Please configure the network from this shell.\n\n";
 822        printf "When you have finished, exit the shell with ^D or exit.\n\n";
 823        shell ()
 824
 825    | Auto ->
 826        printf "Trying network auto-configuration from root filesystem ...\n\n";
 827        if not (auto_network state) then (
 828          printf "\nAuto-configuration failed.  Starting a shell.\n\n";
 829          printf "Please configure the network from this shell.\n\n";
 830          printf "When you have finished, exit the shell with ^D or exit.\n\n";
 831          shell ()
 832        )
 833   );
 834
 835   (* Work out what devices will be called at the remote end. *)
 836   let devices_to_send = List.map (
 837     fun (origin_dev, snapshot_dev) ->
 838       let remote_dev = remote_of_origin_dev origin_dev in
 839       (origin_dev, snapshot_dev, remote_dev)
 840   ) devices_to_send in
 841
 842   rewrite_fstab state devices_to_send;
 843   (* XXX Other files to rewrite? *)
 844
 845   (* Unmount the root filesystem and sync disks. *)
 846   sh "umount /mnt/root";
 847   sh "sync";                            (* Ugh, should be in stdlib. *)
 848
 849   (* For Server and TCP type connections, we connect just once. *)
 850   let remote_host = Option.get state.remote_host in
 851   let remote_port = Option.get state.remote_port in
 852   let remote_directory = Option.get state.remote_directory in
 853   let transport = Option.get state.transport in
 854
 855   let sock =
 856     match transport with
 857     | Server | TCP ->
 858       let addrs =
 859         getaddrinfo remote_host remote_port [AI_SOCKTYPE SOCK_STREAM] in
 860       let rec loop = function
 861         | [] ->
 862             fail_dialog
 863               (sprintf "Unable to connect to %s:%s" remote_host remote_port)
 864         | addr :: addrs ->
 865             try
 866               let sock =
 867                 socket addr.ai_family addr.ai_socktype addr.ai_protocol in
 868               connect sock addr.ai_addr;
 869               sock
 870             with Unix_error (err, syscall, extra) ->
 871               (* Log the error message, but continue around the loop. *)
 872               eprintf "%s:%s: %s\n%!" syscall extra (error_message err);
 873               loop addrs
 874       in
 875       loop addrs
 876     | SSH ->
 877         (* Just dummy socket for SSH for now ... *) stdin in
 878
 879   (* Send the device snapshots to the remote host. *)
 880   (* XXX This is using the hostname derived from network configuration
 881    * above.  We might want to ask the user to choose.
 882    *)
 883   let basename =
 884     let hostname = safe_name (gethostname ()) in
 885     let date = sprintf "%04d%02d%02d%02d%02d"
 886       (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min in
 887     "p2v-" ^ hostname ^ "-" ^ date in
 888
 889   (* XXX This code should be made more robust against both network
 890    * errors and local I/O errors.  Also should allow the user several
 891    * attempts to connect, or let them go back to the dialog stage.
 892    *)
 893   List.iter (
 894     fun (origin_dev, snapshot_dev, remote_dev) ->
 895       let remote_name = basename ^ "-" ^ remote_dev ^ ".img" in
 896       eprintf "sending %s as %s\n%!" origin_dev remote_name;
 897
 898       let size =
 899         try List.assoc origin_dev all_block_devices
 900         with Not_found -> assert false (* internal error *) in
 901
 902       printf "Sending /dev/%s (%.3f GB) to remote machine\n%!" origin_dev
 903         ((Int64.to_float size) /. (1024.*.1024.*.1024.));
 904
 905       (* Open the snapshot device. *)
 906       let fd = openfile ("/dev/mapper/" ^ snapshot_dev) [O_RDONLY] 0 in
 907
 908       (* Now connect (for SSH) or send the header (for Server/TCP). *)
 909       let sock, chan =
 910         match transport with
 911         | Server | TCP ->
 912             let header = sprintf "p2v2 %s %Ld\n%!" remote_name size in
 913             let len = String.length header in
 914             assert (len = write sock header 0 len);
 915             sock, Pervasives.stdout
 916         | SSH ->
 917             let cmd = sprintf "ssh -C -p %s %s \"cat > %s/%s\""
 918               (quote remote_port) (quote remote_host)
 919               (quote remote_directory) (quote remote_name) in
 920             let chan = open_process_out cmd in
 921             let fd = descr_of_out_channel chan in
 922             fd, chan in
 923
 924       (* Copy the data. *)
 925       let bufsize = 128 * 1024 in
 926       let buffer = String.create bufsize in
 927
 928       let rec copy () =
 929         let n = read fd buffer 0 bufsize in
 930         if n > 0 then (
 931           ignore (write sock buffer 0 n);
 932           copy ()
 933         )
 934       in
 935       copy ();
 936
 937       (* For SSH disconnect, for Server/TCP send a newline. *)
 938       match transport with
 939       | Server | TCP ->
 940           ignore (write sock "\n" 0 1)
 941       | SSH ->
 942           match close_process_out chan with
 943           | WEXITED 0 -> ()             (* OK *)
 944           | WEXITED i -> failwith (sprintf "ssh: exited with error code %d" i)
 945           | WSIGNALED i -> failwith (sprintf "ssh: killed by signal %d" i)
 946           | WSTOPPED i -> failwith (sprintf "ssh: stopped by signal %d" i)
 947   ) devices_to_send;
 948
 949   (* Disconnect. *)
 950   (match transport with
 951    | Server | TCP -> close sock
 952    | SSH -> ()
 953   );
 954
 955   (* XXX Write a configuration file. *)
 956   let conf_filename = basename ^ ".conf" in
 957
 958   (* Clean up and reboot. *)
 959   ignore (
 960     msgbox "virt-p2v completed"
 961       (sprintf "\nThe physical to virtual migration is complete.\n\nPlease verify the disk image(s) and configuration file on the remote host, and then start up the virtual machine by doing:\n\nvirsh define %s/%s\n\nWhen you press [OK] this machine will reboot."
 962          (Option.default "" state.remote_directory) conf_filename)
 963       17 50
 964   );
 965
 966   shfailok "eject";
 967   shfailok "reboot";
 968   exit 0
 969
 970 let usage () =
 971   eprintf "usage: virt-p2v [ttyname]\n%!";
 972   exit 2
 973
 974 (* Make sure that exceptions from 'main' get printed out on stdout
 975  * as well as stderr, since stderr is probably redirected to the
 976  * logfile, and so not visible to the user.
 977  *)
 978 let handle_exn f arg =
 979   try f arg
 980   with exn -> print_endline (Printexc.to_string exn); raise exn
 981
 982 (* Test harness for the Makefile.  The Makefile invokes this script as
 983  * 'virt-p2v.ml --test' just to check it compiles.  When it is running
 984  * from the actual live CD, there is a single parameter which is the
 985  * tty name (so usually 'virt-p2v.ml tty1').
 986  *)
 987 let () =
 988   match Array.to_list Sys.argv with
 989   | [ _; "--test" ] -> ()               (* Makefile test - do nothing. *)
 990   | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
 991   | [ _; ttyname ] ->
 992       handle_exn main (Some ttyname)    (* Run main with ttyname. *)
 993   | [ _ ] ->
 994       handle_exn main None              (* Interactive - no ttyname. *)
 995   | _ -> usage ()