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                remote_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 = 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 SSH' or 'Some TCP' to assume SSH or TCP
  64    * respectively.
  65    *)
  66   remote_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 }
  96 (* END OF CUSTOM virt-p2v SCRIPT SECTION.                               *)
  97 (*----------------------------------------------------------------------*)
  98
  99 (* General helper functions. *)
 100
 101 let sort_uniq ?(cmp = compare) xs =     (* sort and uniq a list *)
 102   let xs = List.sort ~cmp xs in
 103   let rec loop = function
 104     | [] -> [] | [x] -> [x]
 105     | x1 :: x2 :: xs when x1 = x2 -> loop (x1 :: xs)
 106     | x :: xs -> x :: loop xs
 107   in
 108   loop xs
 109
 110 let rec string_of_state state =
 111   sprintf
 112     "greeting: %b  remote: %s:%s%s%s  network: %s  devices: [%s]  root: %s"
 113     state.greeting
 114     (Option.default "" state.remote_host)
 115     (Option.default "" state.remote_port)
 116     (match state.remote_transport with
 117      | None -> "" | Some SSH -> " (ssh)" | Some TCP -> " (tcp)")
 118     (match state.remote_directory with
 119      | None -> "" | Some dir -> " " ^ dir)
 120     (match state.network with
 121      | None -> "none" | Some Auto -> "auto" | Some Shell -> "shell")
 122     (String.concat "; " (Option.default [] state.devices_to_send))
 123     (Option.map_default dev_of_partition "" state.root_filesystem)
 124
 125 and dev_of_partition = function
 126   | Part (dev, partnum) -> sprintf "/dev/%s%s" dev partnum
 127   | LV (vg, lv) -> sprintf "/dev/%s/%s" vg lv
 128
 129 type dialog_status = Yes of string list | No | Help | Back | Error
 130
 131 type ask_result = Next of state | Prev | Ask_again
 132
 133 let input_all_lines chan =
 134   let lines = ref [] in
 135   try
 136     while true do lines := input_line chan :: !lines done; []
 137   with
 138     End_of_file -> List.rev !lines
 139
 140 (* Same as `cmd` in shell.  Any error message will be in the logfile. *)
 141 let shget cmd =
 142   let chan = open_process_in cmd in
 143   let lines = input_all_lines chan in
 144   match close_process_in chan with
 145   | WEXITED 0 -> Some lines             (* command succeeded *)
 146   | WEXITED _ -> None                   (* command failed *)
 147   | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i)
 148   | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i)
 149
 150 let is_dir path = (stat path).st_kind = S_DIR
 151
 152 type block_device = string * int64      (* "hda" & size in bytes *)
 153
 154 (* Parse the output of 'lvs' to get list of LV names, sizes,
 155  * corresponding PVs, etc.  Returns a list of (lvname, PVs, lvsize).
 156  *)
 157 let get_lvs =
 158   let whitespace = Pcre.regexp "[ \t]+" in
 159   let comma = Pcre.regexp "," in
 160   let devname = Pcre.regexp "^/dev/(.+)\\(.+\\)$" in
 161
 162   function () ->
 163     match
 164     shget "lvs --noheadings -o vg_name,lv_name,devices,lv_size"
 165     with
 166     | None -> []
 167     | Some lines ->
 168         let lines = List.map (Pcre.split ~rex:whitespace) lines in
 169         List.map (
 170           function
 171           | [vg; lv; pvs; lvsize]
 172           | [_; vg; lv; pvs; lvsize] ->
 173               let pvs = Pcre.split ~rex:comma pvs in
 174               let pvs = List.map (
 175                 fun pv ->
 176                   try
 177                     let subs = Pcre.exec ~rex:devname pv in
 178                     Pcre.get_substring subs 1
 179                   with
 180                     Not_found -> failwith ("lvs: unexpected device name: " ^ pv)
 181               ) pvs in
 182               LV (vg, lv), pvs, lvsize
 183           | line ->
 184               failwith ("lvs: unexpected output: " ^ String.concat "," line)
 185         ) lines
 186
 187 (* Get the partitions on a block device.
 188  * eg. "sda" -> [Part ("sda","1"); Part ("sda", "2")]
 189  *)
 190 let get_partitions dev =
 191   let rex = Pcre.regexp ("^" ^ dev ^ "(.+)$") in
 192   let devdir = "/sys/block/" ^ dev in
 193   let parts = Sys.readdir devdir in
 194   let parts = Array.to_list parts in
 195   let parts = List.filter (fun name -> is_dir (devdir ^ "/" ^ name)) parts in
 196   let parts = List.filter_map (
 197     fun part ->
 198       try
 199         let subs = Pcre.exec ~rex part in
 200         Some (Part (dev, Pcre.get_substring subs 1))
 201       with
 202         Not_found -> None
 203   ) parts in
 204   parts
 205
 206 (* Dialog functions.
 207  *
 208  * Each function takes some common parameters (eg. ~title) and some
 209  * dialog-specific parameters.
 210  *
 211  * Returns the exit status (Yes lines | No | Help | Back | Error).
 212  *)
 213 let msgbox, inputbox, radiolist, checklist =
 214   (* Internal function to actually run the "dialog" shell command. *)
 215   let run_dialog cparams params =
 216     let params = cparams @ params in
 217     eprintf "dialog [%s]\n%!"
 218       (String.concat "; " (List.map (sprintf "%S") params));
 219
 220     (* 'dialog' writes its output/result to stderr, so we need to take
 221      * special steps to capture that - in other words, manual pipe/fork.
 222      *)
 223     let rfd, wfd = pipe () in
 224     match fork () with
 225     | 0 ->                              (* child, runs dialog *)
 226         close rfd;
 227         dup2 wfd stderr;                (* capture stderr to pipe *)
 228         execvp "dialog" (Array.of_list ("dialog" :: params))
 229     | pid ->                            (* parent *)
 230         close wfd;
 231         let chan = in_channel_of_descr rfd in
 232         let result = input_all_lines chan in
 233         close rfd;
 234         eprintf "dialog result: %S\n%!" (String.concat "\n" result);
 235         match snd (wait ()) with
 236         | WEXITED 0 -> Yes result       (* something selected / entered *)
 237         | WEXITED 1 -> No               (* cancel / no button *)
 238         | WEXITED 2 -> Help             (* help pressed *)
 239         | WEXITED 3 -> Back             (* back button *)
 240         | WEXITED _ -> Error            (* error or Esc *)
 241         | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i)
 242         | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i)
 243   in
 244
 245   (* Handle the common parameters.  Note Continuation Passing Style. *)
 246   let with_common cont ?(cancel=false) ?(backbutton=true) title =
 247     let params = ["--title"; title] in
 248     let params = if not cancel then "--nocancel" :: params else params in
 249     let params =
 250       if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params
 251       else params in
 252     cont params
 253   in
 254
 255   (* Message box. *)
 256   let msgbox =
 257     with_common (
 258       fun cparams text height width ->
 259         run_dialog cparams
 260           [ "--msgbox"; text; string_of_int height; string_of_int width ]
 261     )
 262   in
 263
 264   (* Simple input box. *)
 265   let inputbox =
 266     with_common (
 267       fun cparams text height width default ->
 268         run_dialog cparams
 269           [ "--inputbox"; text; string_of_int height; string_of_int width;
 270             default ]
 271     )
 272   in
 273
 274   (* Radio list and check list. *)
 275   let radiolist =
 276     with_common (
 277       fun cparams text height width listheight items ->
 278         let items = List.map (
 279           function
 280           | tag, item, true -> [ tag; item; "on" ]
 281           | tag, item, false -> [ tag; item; "off" ]
 282         ) items in
 283         let items = List.concat items in
 284         let items = "--single-quoted" ::
 285           "--radiolist" :: text ::
 286           string_of_int height :: string_of_int width ::
 287           string_of_int listheight :: items in
 288         run_dialog cparams items
 289     )
 290   in
 291
 292   let checklist =
 293     with_common (
 294       fun cparams text height width listheight items ->
 295         let items = List.map (
 296           function
 297           | tag, item, true -> [ tag; item; "on" ]
 298           | tag, item, false -> [ tag; item; "off" ]
 299         ) items in
 300         let items = List.concat items in
 301         let items = "--separate-output" ::
 302           "--checklist" :: text ::
 303           string_of_int height :: string_of_int width ::
 304           string_of_int listheight :: items in
 305         run_dialog cparams items
 306     )
 307   in
 308   msgbox, inputbox, radiolist, checklist
 309
 310 (* Print failure dialog and exit. *)
 311 let fail_dialog text =
 312   let text = 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
 313   ignore (msgbox "Error" text 17 50);
 314   exit 1
 315
 316 (* Main entry point. *)
 317 let rec main ttyname =
 318   (* Running from an init script.  We don't have much of a
 319    * login environment, so set one up.
 320    *)
 321   putenv "PATH"
 322     (String.concat ":"
 323        ["/usr/sbin"; "/sbin"; "/usr/local/bin"; "/usr/kerberos/bin";
 324         "/usr/bin"; "/bin"]);
 325   putenv "HOME" "/root";
 326   putenv "LOGNAME" "root";
 327
 328   (* We can safely write in /tmp (it's a synthetic live CD directory). *)
 329   chdir "/tmp";
 330
 331   (* Set up logging to /tmp/virt-p2v.log. *)
 332   let fd = openfile "virt-p2v.log" [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in
 333   dup2 fd stderr;
 334   close fd;
 335
 336   (* Log the start up time. *)
 337   eprintf "\n\n**************************************************\n\n";
 338   let tm = localtime (time ()) in
 339   eprintf "virt-p2v-ng starting up at %04d-%02d-%02d %02d:%02d:%02d\n\n%!"
 340     (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec;
 341
 342   (* Connect stdin/stdout to the tty. *)
 343   (match ttyname with
 344    | None -> ()
 345    | Some ttyname ->
 346        let fd = openfile ("/dev/" ^ ttyname) [ O_RDWR ] 0 in
 347        dup2 fd stdin;
 348        dup2 fd stdout;
 349        close fd);
 350
 351   (* Search for all non-removable block devices.  Do this early and bail
 352    * if we can't find anything.  This is a list of strings, like "hda".
 353    *)
 354   let all_block_devices : block_device list =
 355     let rex = Pcre.regexp "^[hs]d" in
 356     let devices = Array.to_list (Sys.readdir "/sys/block") in
 357     let devices = List.sort devices in
 358     let devices = List.filter (fun d -> Pcre.pmatch ~rex d) devices in
 359     eprintf "all_block_devices: block devices: %s\n%!"
 360       (String.concat "; " devices);
 361     (* Run blockdev --getsize64 on each, and reject any where this fails
 362      * (probably removable devices).
 363      *)
 364     let devices = List.filter_map (
 365       fun d ->
 366         let cmd = "blockdev --getsize64 /dev/" ^ Filename.quote d in
 367         let lines = shget cmd in
 368         match lines with
 369         | Some (blksize::_) -> Some (d, Int64.of_string blksize)
 370         | Some [] | None -> None
 371     ) devices in
 372     eprintf "all_block_devices: non-removable block devices: %s\n%!"
 373       (String.concat "; "
 374          (List.map (fun (d, b) -> sprintf "%s [%Ld]" d b) devices));
 375     if devices = [] then
 376       fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine.";
 377     devices in
 378
 379   (* Search for partitions and LVs (anything that could contain a
 380    * filesystem directly).  We refer to these generically as
 381    * "partitions".
 382    *)
 383   let all_partitions : partition list =
 384     (* LVs & PVs. *)
 385     let lvs, pvs =
 386       let lvs = get_lvs () in
 387       let pvs = List.map (fun (_, pvs, _) -> pvs) lvs in
 388       let pvs = List.concat pvs in
 389       let pvs = sort_uniq pvs in
 390       eprintf "all_partitions: PVs: %s\n%!" (String.concat "; " pvs);
 391       let lvs = List.map (fun (lvname, _, _) -> lvname) lvs in
 392       eprintf "all_partitions: LVs: %s\n%!"
 393         (String.concat "; " (List.map dev_of_partition lvs));
 394       lvs, pvs in
 395
 396     (* Partitions (eg. "sda1", "sda2"). *)
 397     let parts =
 398       let parts = List.map fst all_block_devices in
 399       let parts = List.map get_partitions parts in
 400       let parts = List.concat parts in
 401       eprintf "all_partitions: all partitions: %s\n%!"
 402         (String.concat "; " (List.map dev_of_partition parts));
 403
 404       (* Remove any partitions which are PVs. *)
 405       let parts = List.filter (
 406         function
 407         | Part (dev, partnum) -> not (List.mem (dev ^ partnum) pvs)
 408         | LV _ -> assert false
 409       ) parts in
 410       parts in
 411     eprintf "all_partitions: partitions after removing PVs: %s\n%!"
 412       (String.concat "; " (List.map dev_of_partition parts));
 413
 414     (* Concatenate LVs & Parts *)
 415     lvs @ parts in
 416
 417   (* Dialogs. *)
 418   let ask_greeting state =
 419     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);
 420     Next state
 421   in
 422
 423   let ask_transport state =
 424     match
 425     radiolist "Connection type" ~backbutton:false
 426       "Connection type" 10 50 2 [
 427         "ssh", "SSH (secure shell - recommended)",
 428           state.remote_transport = Some SSH;
 429         "tcp", "TCP socket",
 430           state.remote_transport = Some TCP
 431       ]
 432     with
 433     | Yes ("ssh"::_) -> Next { state with remote_transport = Some SSH }
 434     | Yes ("tcp"::_) -> Next { state with remote_transport = Some TCP }
 435     | Yes _ | No | Help | Error -> Ask_again
 436     | Back -> Prev
 437   in
 438
 439   let ask_hostname state =
 440     match
 441     inputbox "Remote host" "Remote host" 10 50
 442       (Option.default "" state.remote_host)
 443     with
 444     | Yes [] -> Ask_again
 445     | Yes (hostname::_) -> Next { state with remote_host = Some hostname }
 446     | No | Help | Error -> Ask_again
 447     | Back -> Prev
 448   in
 449
 450   let ask_port state =
 451     match
 452     inputbox "Remote port" "Remote port" 10 50
 453       (Option.default "" state.remote_port)
 454     with
 455     | Yes [] ->
 456         if state.remote_transport = Some TCP then
 457           Next { state with remote_port = Some "16211" }
 458         else
 459           Next { state with remote_port = Some "22" }
 460     | Yes (port::_) -> Next { state with remote_port = Some port }
 461     | No | Help | Error -> Ask_again
 462     | Back -> Prev
 463   in
 464
 465   let ask_directory state =
 466     match
 467     inputbox "Remote directory" "Remote directory" 10 50
 468       (Option.default "" state.remote_directory)
 469     with
 470     | Yes [] ->
 471         Next { state with remote_directory = Some "/var/lib/xen/images" }
 472     | Yes (dir::_) -> Next { state with remote_directory = Some dir }
 473     | No | Help | Error -> Ask_again
 474     | Back -> Prev
 475   in
 476
 477   let ask_network state =
 478     match
 479     radiolist "Network configuration" "Network configuration" 10 50 2 [
 480       "auto", "Automatic configuration", state.network = Some Auto;
 481       "sh", "Configure from the shell", state.network = Some Shell;
 482     ]
 483     with
 484     | Yes ("auto"::_) -> Next { state with network = Some Auto }
 485     | Yes ("sh"::_) -> Next { state with network = Some Shell }
 486     | Yes _ | No | Help | Error -> Ask_again
 487     | Back -> Prev
 488   in
 489
 490   let ask_devices state =
 491     let selected_devices = Option.default [] state.devices_to_send in
 492     let devices = List.map (
 493       fun (dev, blksize) ->
 494         (dev,
 495          sprintf "/dev/%s (%.3f GB)" dev
 496            ((Int64.to_float blksize) /. (1024.*.1024.*.1024.)),
 497          List.mem dev selected_devices)
 498     ) all_block_devices in
 499     match
 500     checklist "Devices" "Pick devices to send" 15 50 8 devices
 501     with
 502     | Yes [] | No | Help | Error -> Ask_again
 503     | Yes devices -> Next { state with devices_to_send = Some devices }
 504     | Back -> Prev
 505   in
 506
 507   let ask_root state =
 508     let parts = List.mapi (
 509       fun i part ->
 510         (string_of_int i, dev_of_partition part,
 511          Some part = state.root_filesystem)
 512     ) all_partitions in
 513     match
 514     radiolist "Root device"
 515       "Pick partition containing the root (/) filesystem" 15 50 6
 516       parts
 517     with
 518     | Yes (i::_) ->
 519         let part = List.nth all_partitions (int_of_string i) in
 520         Next { state with root_filesystem = Some part }
 521     | Yes [] | No | Help | Error -> Ask_again
 522     | Back -> Prev
 523   in
 524
 525   (* This is the list of dialogs, in order.  The user can go forwards or
 526    * backwards through them.  The second parameter in each pair is
 527    * false if we need to skip this dialog (info already supplied in
 528    * 'defaults' above).
 529    *)
 530   let dlgs = [|
 531     ask_greeting,                       (* Initial greeting. *)
 532       defaults.greeting;
 533     ask_transport,                      (* Transport (ssh, tcp) *)
 534       defaults.remote_transport = None;
 535     ask_hostname,                       (* Hostname. *)
 536       defaults.remote_host = None;
 537     ask_port,                           (* Port number. *)
 538       defaults.remote_port = None;
 539     ask_directory,                      (* Remote directory. *)
 540       defaults.remote_directory = None;
 541     ask_network,                        (* Network configuration. *)
 542       defaults.network = None;
 543     ask_devices,                        (* Block devices to send. *)
 544       defaults.devices_to_send = None;
 545     ask_root,                           (* Root filesystem. *)
 546       defaults.root_filesystem = None;
 547 (*    ask_verify,                               (* Verify settings. *)
 548       defaults.greeting*)
 549   |] in
 550
 551   (* Loop through the dialogs until we reach the end. *)
 552   let rec loop posn state =
 553     eprintf "dialog loop: posn = %d\n%!" posn;
 554     if posn >= Array.length dlgs then state (* Finished all dialogs. *)
 555     else (
 556       let dlg, no_skip = dlgs.(posn) in
 557       let skip = not no_skip in
 558       if skip then
 559         (* Skip this dialog and move straight to the next one. *)
 560         loop (posn+1) state
 561       else (
 562         (* Run dialog. *)
 563         match dlg state with
 564         | Next new_state -> loop (posn+1) new_state (* Forwards. *)
 565         | Prev -> loop (posn-1) state       (* Backwards / back button. *)
 566         | Ask_again -> loop posn state      (* Repeat the question. *)
 567       )
 568     )
 569   in
 570   let state = loop 0 defaults in
 571
 572   eprintf "finished dialog loop\nstate = %s\n%!" (string_of_state state);
 573
 574
 575
 576
 577
 578
 579   ()
 580
 581 let usage () =
 582   eprintf "usage: virt-p2v [ttyname]\n%!";
 583   exit 2
 584
 585 (* Test harness for the Makefile.  The Makefile invokes this script as
 586  * 'virt-p2v.ml --test' just to check it compiles.  When it is running
 587  * from the actual live CD, there is a single parameter which is the
 588  * tty name (so usually 'virt-p2v.ml tty1').
 589  *)
 590 let () =
 591   match Array.to_list Sys.argv with
 592   | [ _; "--test" ] -> ()            (* Makefile test - do nothing. *)
 593   | [ _; ("--help"|"-help"|"-?"|"-h") ] -> usage ();
 594   | [ _; ttyname ] -> main (Some ttyname) (* Run main with ttyname. *)
 595   | [ _ ] -> main None                 (* Interactive - no ttyname. *)
 596   | _ -> usage ()