virt-ctrl/vc_install_dlg.ml

   1 (* virt-ctrl: A graphical management tool.
   2    (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4
   5    This program is free software; you can redistribute it and/or modify
   6    it under the terms of the GNU General Public License as published by
   7    the Free Software Foundation; either version 2 of the License, or
   8    (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful,
  11    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13    GNU General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18 *)
  19
  20 open Printf
  21 open Unix
  22 open ExtList
  23 open Xml
  24
  25 open Virt_ctrl_gettext.Gettext
  26
  27 let (//) = Filename.concat
  28
  29 type virt_type =
  30   | VT_HVM | VT_Xen | UnknownVirtType
  31 type arch =
  32   | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
  33   | OtherArch of string
  34   | UnknownArch
  35 type hv_name =                          (* implicitly ordered worst->best *)
  36   | UnknownHVType | QEMU | Xen | KVM
  37
  38 (* List of supported distros.  The name field must be unique but
  39  * doesn't need to be constant.
  40  *)
  41 let distros = [
  42   "Fedora 8 (i386, 32 bit, Xen paravirtualized)", (
  43     VT_Xen, I386
  44   );
  45   "Fedora 8 (i386, 32 bit, fully virtualized)", (
  46     VT_HVM, I386
  47   );
  48   "Fedora 8 (x86-64, 64 bit, Xen paravirtualized)", (
  49     VT_Xen, X86_64
  50   );
  51   "Fedora 8 (x86-64, 64 bit, fully virtualized)", (
  52     VT_HVM, X86_64
  53   );
  54   "Fedora 9 (i386, 32 bit, Xen paravirtualized)", (
  55     VT_Xen, I386
  56   );
  57   "Fedora 9 (i386, 32 bit, fully virtualized)", (
  58     VT_HVM, I386
  59   );
  60   "Fedora 9 (x86-64, 64 bit, Xen paravirtualized)", (
  61     VT_Xen, X86_64
  62   );
  63   "Fedora 9 (x86-64, 64 bit, fully virtualized)", (
  64     VT_HVM, X86_64
  65   );
  66 ]
  67
  68 let string_of_virt_type = function
  69   | VT_HVM -> "hvm"
  70   | VT_Xen -> "xen"
  71   | UnknownVirtType -> invalid_arg "string_of_virt_type"
  72
  73 let string_of_architecture = function
  74   | I386 -> "i386"
  75   | X86_64 -> "x86_64"
  76   | IA64 -> "ia64"
  77   | PPC -> "ppc"
  78   | PPC64 -> "ppc64"
  79   | SPARC -> "sparc"
  80   | SPARC64 -> "sparc64"
  81   | OtherArch arch -> arch
  82   | UnknownArch -> invalid_arg "string_of_architecture"
  83
  84 let architecture_of_string = function
  85   | str when
  86       String.length str = 4 &&
  87       (str.[0] = 'i' || str.[0] = 'I') &&
  88       (str.[1] >= '3' && str.[1] <= '6') &&
  89       str.[2] = '8' && str.[3] = '6' -> I386
  90   | "x86_64" | "X86_64" | "x86-64" | "X86-64" -> X86_64
  91   | "ia64" | "IA64" -> IA64
  92   | "ppc" | "PPC" | "ppc32" | "PPC32" -> PPC
  93   | "ppc64" | "PPC64" -> PPC64
  94   | "sparc" | "SPARC" | "sparc32" | "SPARC32" -> SPARC
  95   | "sparc64" | "SPARC64" -> SPARC64
  96   | str -> OtherArch str
  97
  98 let string_of_hv_name = function
  99   | Xen -> "Xen"
 100   | QEMU -> "QEMU"
 101   | KVM -> "KVM"
 102   | UnknownHVType -> "unknown"
 103
 104 (* Choose a disk location for images.
 105  * This changed in libvirt 0.4.something.
 106  *)
 107 let disk_location =
 108   let dirs = [
 109     "/var/lib/libvirt/images";
 110     "/var/lib/libvirt/xen";
 111   ] in
 112   let dirs =
 113     try dirs @ [Sys.getenv "HOME"]
 114     with Not_found -> dirs in
 115   try
 116     List.find (
 117       fun d ->
 118         try (stat d).st_kind = S_DIR
 119         with Unix_error _ -> false
 120     ) dirs
 121   with
 122     Not_found -> "/var/tmp"
 123
 124 type edit_status = UserEdit | ProgramEdit | Disconnected
 125
 126 let rec find_map f = function
 127   | [] -> raise Not_found
 128   | x :: xs ->
 129       match f x with
 130       | Some y -> y
 131       | None -> find_map f xs
 132
 133 (* Install guest dialog. *)
 134 let rec install_guest parent conn_id () =
 135   let title = s_"Install new guest" in
 136   let position = `CENTER_ON_PARENT in
 137
 138   let dlg = GWindow.dialog ~title ~position ~parent ~modal:true () in
 139
 140   (* We will enter the Gtk main loop recursively.  Wire up close and
 141    * other buttons to quit the recursive main loop.
 142    *)
 143   ignore (dlg#connect#destroy ~callback:GMain.quit);
 144   ignore (dlg#event#connect#delete
 145             ~callback:(fun _ -> GMain.quit (); false));
 146
 147   (* Action area. *)
 148   let cancel_button =
 149     GButton.button ~label:(s_"Cancel") ~packing:dlg#action_area#pack () in
 150   ignore (cancel_button#connect#clicked ~callback:dlg#destroy);
 151
 152   let install_button =
 153     GButton.button ~label:(s_"Install") ~packing:dlg#action_area#pack () in
 154
 155   (* Connections. *)
 156   let conns = get_connections () in
 157
 158   let frame =
 159     GBin.frame ~label:(s_"Hypervisor connection")
 160       ~packing:dlg#vbox#pack () in
 161   let hbox = GPack.hbox ~packing:frame#add () in
 162
 163   ignore (GMisc.label ~text:(s_"Connection:") ~xalign:1.0
 164             ~packing:hbox#pack ());
 165
 166   let conn_combo, (conn_model : GTree.list_store), conn_col_id, conn_active =
 167     populate_conns conns hbox#pack conn_id in
 168
 169   (* Distro. *)
 170   let frame =
 171     GBin.frame ~label:(s_"Operating system") ~packing:dlg#vbox#pack () in
 172
 173   let (distro_combo, (distro_list, distro_col_name)) =
 174     GEdit.combo_box_text ~packing:frame#add () in
 175
 176   (* VM name. *)
 177   let frame =
 178     GBin.frame ~label:(s_"Guest details") ~packing:dlg#vbox#pack () in
 179
 180   let tbl = GPack.table ~columns:3 ~rows:5 ~packing:frame#add () in
 181
 182   ignore (GMisc.label ~text:(s_"Name:") ~xalign:1.0
 183             ~packing:(tbl#attach ~top:0 ~left:0) ());
 184   let name_entry =
 185     GEdit.entry ~width_chars:32
 186       ~packing:(tbl#attach ~top:0 ~left:1) () in
 187
 188   (* Disk image. *)
 189   ignore (GMisc.label ~text:(s_"Disk image:") ~xalign:1.0
 190             ~packing:(tbl#attach ~top:1 ~left:0) ());
 191   let disk_entry =
 192     GEdit.entry ~width_chars:48
 193       ~packing:(tbl#attach ~top:1 ~left:1) () in
 194   let hbox = GPack.hbox ~packing:(tbl#attach ~top:1 ~left:2) () in
 195   let disk_size =
 196     GEdit.spin_button ~numeric:true ~digits:1
 197       ~packing:hbox#pack () in
 198   disk_size#adjustment#set_bounds ~lower:2.0 ~upper:999.0 ~step_incr:0.5 ();
 199   disk_size#adjustment#set_value 8.0;
 200   ignore (GMisc.label ~text:" GB" ~packing:hbox#pack ());
 201
 202   (* Network. *)
 203   ignore (GMisc.label ~text:(s_"Network:") ~xalign:1.0
 204             ~packing:(tbl#attach ~top:2 ~left:0) ());
 205   let (net_combo, _) =
 206     GEdit.combo_box_text
 207       ~strings:["default"] (* XXX not implemented *)
 208       ~packing:(tbl#attach ~top:2 ~left:1) () in
 209   net_combo#set_active 0;
 210
 211   (* RAM. *)
 212   ignore (GMisc.label ~text:(s_"RAM:") ~xalign:1.0
 213             ~packing:(tbl#attach ~top:3 ~left:0) ());
 214   let hbox = GPack.hbox ~packing:(tbl#attach ~top:3 ~left:1) () in
 215   let ram =
 216     GEdit.spin_button ~numeric:true ~digits:0
 217       ~packing:hbox#pack () in
 218   ram#adjustment#set_bounds ~lower:128.0 ~upper:131_072.0 ~step_incr:32.0 ();
 219   ram#adjustment#set_value 512.0;
 220   ignore (GMisc.label ~text:" MB" ~packing:hbox#pack ());
 221
 222   (* CPUs. *)
 223   ignore (GMisc.label ~text:(s_"CPUs:") ~xalign:1.0
 224             ~packing:(tbl#attach ~top:4 ~left:0) ());
 225   let hbox = GPack.hbox ~packing:(tbl#attach ~top:4 ~left:1) () in
 226   let vcpus =
 227     GEdit.spin_button ~numeric:true ~digits:0
 228       ~packing:hbox#pack () in
 229   vcpus#adjustment#set_bounds ~lower:1.0 ~upper:4.0 ~step_incr:1.0 ();
 230   vcpus#adjustment#set_value 1.0;
 231
 232   let () =
 233     (* When connection combo changes we need to repopulate list of distros. *)
 234     ignore (
 235       conn_combo#connect#changed
 236         ~callback:(
 237           fun () ->
 238             repopulate_distros conns conn_combo conn_model conn_col_id
 239               distro_combo distro_list distro_col_name
 240         )
 241     );
 242
 243     (* When distro changes we need to change the name, provided the name
 244      * hasn't been edited by the user (in which case we leave it alone).
 245      *
 246      * We have to use a shared reference so that we don't disconnect
 247      * the signal when we are editing the field (not the user).  Ugh ...
 248      *)
 249     let edit_status = ref UserEdit in
 250     let distro_changed_id =
 251       distro_combo#connect#changed
 252         ~callback:(
 253           fun () ->
 254             let row = distro_combo#active_iter in
 255             match row with
 256             | None -> ()                (* no distro selected *)
 257             | Some row ->
 258                 let name = distro_list#get ~row ~column:distro_col_name in
 259                 let name = short_name_of_distro name in
 260
 261                 let old_status = !edit_status in
 262                 edit_status := ProgramEdit;
 263                 name_entry#set_text name;
 264                 disk_entry#set_text (disk_location // name ^ ".img");
 265                 edit_status := old_status
 266         ) in
 267
 268     ignore (
 269       name_entry#connect#changed ~callback:(
 270         fun () ->
 271           if !edit_status = UserEdit then (
 272             distro_combo#misc#disconnect distro_changed_id;
 273             edit_status := Disconnected (* prevent multiple disconnections *)
 274           )
 275       )
 276     );
 277
 278     ignore (
 279       disk_entry#connect#changed ~callback:(
 280         fun () ->
 281           if !edit_status = UserEdit then (
 282             distro_combo#misc#disconnect distro_changed_id;
 283             edit_status := Disconnected (* prevent multiple disconnections *)
 284           )
 285       )
 286     );
 287
 288     (* Wire up the install button. *)
 289     ignore (
 290       install_button#connect#clicked ~callback:(
 291         fun () ->
 292           (* Get the required settings. *)
 293           let conn_id =
 294             match conn_combo#active_iter with
 295             | None ->                   (* no connection selected *)
 296                 invalid_arg (s_"No connection selected")
 297             | Some row ->
 298                 conn_model#get ~row ~column:conn_col_id in
 299           let distro =
 300             match distro_combo#active_iter with
 301             | None ->                   (* no distro selected *)
 302                 invalid_arg (s_"No operating system selected")
 303             | Some row ->
 304                 distro_list#get ~row ~column:distro_col_name in
 305           let name = name_entry#text in
 306           let disk = disk_entry#text in
 307           let disk_size = disk_size#value in
 308           let net = "default" (* XXX network not implemented *) in
 309           let ram = ram#value_as_int in
 310           let vcpus = vcpus#value_as_int in
 311
 312           dlg#destroy ();
 313           start_install parent conns
 314             conn_id distro name disk disk_size net ram vcpus
 315       )
 316     ) in
 317
 318   (* See combobox.ml example in %doc directory.
 319    * NB. Don't use ~active label above.  It is buggy and won't trigger
 320    * the selection callback.
 321    *)
 322   conn_combo#set_active conn_active;
 323
 324   (* Set focus on the distro. *)
 325   distro_combo#misc#grab_focus ();
 326
 327   dlg#show ();
 328
 329   (* Enter Gtk main loop recursively. *)
 330   GMain.main ()
 331
 332 (* Populate the list of connections. *)
 333 and populate_conns conns packing conn_id =
 334   (* Model/columns. *)
 335   let cols = new GTree.column_list in
 336   let col_name = cols#add Gobject.Data.string in
 337   let col_id = cols#add Gobject.Data.int in
 338   let model = GTree.list_store cols in
 339
 340   (* View. *)
 341   let conn_combo = GEdit.combo_box ~model ~packing () in
 342
 343   let renderer = GTree.cell_renderer_text [] in
 344   conn_combo#pack renderer;
 345   ignore (conn_combo#add_attribute renderer "text" col_name);
 346
 347   (* Populate the connection combo box. *)
 348   let active = ref 0 in
 349   List.iteri (
 350     fun i (id, (conn, hostname, guests)) ->
 351       if id = conn_id then active := i;
 352
 353       let name =
 354         (* Get unique list of all HV types supported. *)
 355         let hvs = List.map (fun (_, _, domains) -> domains) guests in
 356         let hvs = List.concat hvs in
 357         let hvs = List.map fst hvs in
 358         let hvs = List.unique hvs in
 359         let hvs = List.sort hvs in
 360
 361         (* Make a printable string for this connection. *)
 362         sprintf "%s (%s)" hostname
 363           (String.concat "/" (List.map string_of_hv_name hvs)) in
 364
 365       let row = model#append () in
 366       model#set ~row ~column:col_name name;
 367       model#set ~row ~column:col_id conn_id
 368   ) conns;
 369
 370   conn_combo, model, col_id, !active
 371
 372 (* When connection combo selection changes, repopulate list of distros. *)
 373 and repopulate_distros conns conn_combo conn_model conn_col_id
 374     distro_combo distro_list distro_col_name =
 375   (* Clear the distro list. *)
 376   distro_list#clear ();
 377
 378   let row = conn_combo#active_iter in
 379   match row with
 380   | None -> ()                          (* no connection selected *)
 381   | Some row ->
 382       let conn_id = conn_model#get ~row ~column:conn_col_id in
 383       let conn, hostname, guests = List.assoc conn_id conns in
 384
 385       (* Get the distros which match one of the guest types. *)
 386       let distros = List.map get_matching_distros guests in
 387       let distros = List.concat distros in
 388       let distros = List.unique distros in
 389       let distros = List.sort distros in
 390
 391       (* Populate the list with distros which match. *)
 392       List.iter (
 393         fun (name, _) ->
 394           let row = distro_list#append () in
 395           distro_list#set ~row ~column:distro_col_name name
 396       ) distros;
 397
 398       if List.length distros > 0 then distro_combo#set_active 0
 399
 400 and get_matching_distros (virt_type, arch, domains) =
 401   List.filter (
 402     fun (_, (virt_type', arch')) ->
 403       virt_type = virt_type' && arch = arch'
 404   ) distros
 405
 406 (* Get a short name from the selected distro's name. *)
 407 and short_name_of_distro name =
 408   let len = String.length name in
 409   let buf = Buffer.create 16 in
 410   let rec loop i =
 411     if i < len then (
 412       let c = name.[i] in
 413       match c with
 414       | 'A' .. 'Z' ->
 415           Buffer.add_char buf (Char.chr (Char.code c + 0x20));
 416           loop (i+1)
 417       | 'a' .. 'z' | '0' .. '9' ->
 418           Buffer.add_char buf c;
 419           loop (i+1)
 420       | '(' -> ()                       (* stop at first '(' character *)
 421       | _ -> loop (i+1)
 422     )
 423   in
 424   loop 0;
 425   Buffer.contents buf
 426
 427 (* Get connection details, mainly from the capabilities XML. *)
 428 and get_connections () =
 429   let conns = Vc_connections.get_conns () in
 430   List.map (
 431     fun (conn_id, conn) ->
 432       let hostname =
 433         match Vc_connections.get_hostname conn_id with
 434         | Some hostname -> hostname
 435         | None -> sprintf "Conn #%d" conn_id in
 436
 437       (* Get some idea of what the hypervisor supports. *)
 438       let guests =
 439         let caps = Vc_connections.get_capabilities conn_id in
 440         match caps with
 441         | Some (Element ("capabilities", _, children)) ->
 442             List.filter_map (
 443               function
 444               | Element ("guest", _, children) -> Some children
 445               | _ -> None
 446             ) children
 447         | _ -> [] in             (* XXX should do better if no caps *)
 448
 449       let guests =
 450         List.map (
 451           fun guest ->
 452             let os_type =
 453               try
 454                 find_map (
 455                   function
 456                   | Element ("os_type", _, [PCData "hvm"]) -> Some VT_HVM
 457                   | Element ("os_type", _, [PCData "xen"]) -> Some VT_Xen
 458                   | _ -> None
 459                 ) guest
 460               with
 461                 Not_found -> UnknownVirtType in
 462
 463             let arch, domains =
 464               try
 465                 find_map (
 466                   function
 467                   | Element ("arch", attrs, children) ->
 468                       let arch =
 469                         try architecture_of_string (List.assoc "name" attrs)
 470                         with Not_found -> UnknownArch in
 471                       let domains =
 472                         List.filter_map (
 473                           function
 474                           | Element ("domain", attrs, children) ->
 475                               let domtype =
 476                                 try
 477                                   match List.assoc "type" attrs with
 478                                   | "xen" -> Xen
 479                                   | "qemu" -> QEMU
 480                                   | "kvm" -> KVM
 481                                   | _ -> UnknownHVType
 482                                 with Not_found -> UnknownHVType in
 483                               Some (domtype, children)
 484                           | _ -> None
 485                         ) children in
 486                       Some (arch, domains)
 487                   | _ -> None
 488                 ) guest
 489               with
 490                 Not_found -> UnknownArch, [] in
 491
 492             (os_type, arch, domains)
 493         ) guests in
 494
 495       (conn_id, (conn, hostname, guests))
 496   ) conns
 497
 498 (* Perform (or at least start off) the install. *)
 499 and start_install parent conns
 500     conn_id distro name disk disk_size net ram vcpus =
 501   (* Create new toplevel dialog to show the progress of the steps. *)
 502   let title = s_"Guest installing" in
 503   let position = `CENTER_ON_PARENT in
 504
 505   let dlg = GWindow.dialog
 506     ~title ~position ~parent ~modal:false ~width:480 () in
 507
 508   let frame =
 509     GBin.frame ~label:(s_ "Download kernel") ~packing:dlg#vbox#pack () in
 510   let kernel_bar = GRange.progress_bar ~packing:frame#add () in
 511
 512   let frame =
 513     GBin.frame ~label:(s_ "Download initrd") ~packing:dlg#vbox#pack () in
 514   let initrd_bar = GRange.progress_bar ~packing:frame#add () in
 515
 516   let frame =
 517     GBin.frame ~label:(s_ "Create disk image") ~packing:dlg#vbox#pack () in
 518   let disk_bar = GRange.progress_bar ~packing:frame#add () in
 519
 520   (* We will enter the Gtk main loop recursively.  Wire up close and
 521    * other buttons to quit the recursive main loop.
 522    *)
 523   ignore (dlg#connect#destroy ~callback:GMain.quit);
 524   ignore (dlg#event#connect#delete
 525             ~callback:(fun _ -> GMain.quit (); false));
 526
 527   (* Action area. *)
 528   let cancel_button =
 529     GButton.button ~label:(s_"Cancel") ~packing:dlg#action_area#pack () in
 530   ignore (cancel_button#connect#clicked ~callback:dlg#destroy);
 531
 532 (*
 533   (* Create the disk image if necessary.
 534    * XXX Should have checked earlier if it already exists.
 535    *)
 536   let disk_exists =
 537     try (stat disk).st_kind = S_REG
 538     with Unix_error _ -> false in
 539   if not disk_exists then (
 540     try
 541       let fd = openfile disk [O_WRONLY;O_CREAT] in
 542       let onemeg = 1024*1024 in
 543       let buffer = String.make onemeg '\000' in
 544       let nmegs = int_of_float (disk_size *. 1024.) in
 545       for i = 0 to nmegs-1 do
 546         write fd buffer 0 onemeg
 547       done;
 548       close fd
 549     with
 550       exn ->
 551         (* Remove the disk image. *)
 552         (try unlink disk with _ -> ());
 553         (* Re-raise the original exception. *)
 554         raise exn
 555   );
 556 *)
 557
 558   (* Get the distro by name. *)
 559   let virt_type, arch = List.assoc distro distros in
 560
 561   (* Generate the XML configuration. *)
 562   let xml =
 563     (* Shortcut to make "<name>value</name>". *)
 564     let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
 565     (* ... and the _other_ sort of leaf (god I hate XML). *)
 566     let tleaf name attribs = Xml.Element (name, attribs, []) in
 567
 568     (* Standard stuff for every domain. *)
 569     let name = leaf "name" name in
 570     let uuid = leaf "uuid" (random_uuid ()) in
 571     let maxmem, memory =
 572       let m = string_of_int (ram * 1024) in
 573       leaf "maxmem" m, leaf "memory" m in
 574     let vcpus = leaf "vcpu" (string_of_int vcpus) in
 575
 576     (* <os> section, describes kernel, boot locations. *)
 577
 578
 579
 580
 581     (* Put it all together in <domain type='foo'>. *)
 582     Xml.Element (
 583       "domain",
 584       [ "type", string_of_virt_type virt_type ],
 585       name :: uuid :: memory :: maxmem :: vcpus :: []
 586     ) in
 587
 588   let xml = Xml.to_string_fmt xml in
 589
 590   prerr_endline xml;
 591
 592   dlg#show ();
 593
 594   (* Enter Gtk main loop recursively. *)
 595   GMain.main ()
 596
 597 (* Generate a random MAC address in the Xen-reserved space. *)
 598 and random_mac_address () =
 599   let random =
 600     List.map (sprintf "%02x") (
 601       List.map (fun _ -> Random.int 256) [0;0;0]
 602     ) in
 603   String.concat ":" ("00"::"16"::"3e"::random)
 604
 605 (* Generate a random UUID. *)
 606 and random_uuid =
 607   let hex = "0123456789abcdef" in
 608   fun () ->
 609   let str = String.create 32 in
 610   for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
 611   str