virt-ctrl/vc_mainwindow.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 Virt_ctrl_gettext.Gettext
  22
  23 let title = s_ "Virtual Control"
  24
  25 let utf8_copyright = "\194\169"
  26
  27 let help_about () =
  28   let gtk_version =
  29     let gtk_major, gtk_minor, gtk_micro = GMain.Main.version in
  30     sprintf "%d.%d.%d" gtk_major gtk_minor gtk_micro in
  31   let virt_version = string_of_int (fst (Libvirt.get_version ())) in
  32   let title = "About " ^ title in
  33   let icon = GMisc.image () in
  34   icon#set_stock `DIALOG_INFO;
  35   icon#set_icon_size `DIALOG;
  36   GToolbox.message_box
  37     ~title
  38     ~icon
  39     (sprintf (f_ "Virtualization control tool (virt-ctrl) by
  40 Richard W.M. Jones (rjones@redhat.com).
  41
  42 Copyright %s 2007-2008 Red Hat Inc.
  43
  44 Libvirt version: %s
  45
  46 Gtk toolkit version: %s") utf8_copyright virt_version gtk_version)
  47
  48 (* Catch any exception and throw up a dialog. *)
  49 let () =
  50   (* A nicer exception printing function. *)
  51   let string_of_exn = function
  52     | Libvirt.Virterror err ->
  53         s_ "Virtualisation error" ^ ": " ^ (Libvirt.Virterror.to_string err)
  54     | Failure msg -> msg
  55     | exn -> Printexc.to_string exn
  56   in
  57   GtkSignal.user_handler :=
  58     fun exn ->
  59       let label = string_of_exn exn in
  60       prerr_endline label;
  61       let title = s_ "Error" in
  62       let icon = GMisc.image () in
  63       icon#set_stock `DIALOG_ERROR;
  64       icon#set_icon_size `DIALOG;
  65       GToolbox.message_box ~title ~icon label
  66
  67 let make
  68     ~start_domain ~pause_domain ~resume_domain ~shutdown_domain
  69     ~open_domain_details =
  70   (* Create the main window. *)
  71   let window = GWindow.window ~width:800 ~height:600 ~title () in
  72   let vbox = GPack.vbox ~packing:window#add () in
  73
  74   (* Menu bar. *)
  75   let quit_item =
  76     let menubar = GMenu.menu_bar ~packing:vbox#pack () in
  77     let factory = new GMenu.factory menubar in
  78     let accel_group = factory#accel_group in
  79     let file_menu = factory#add_submenu (s_ "File") in
  80     let help_menu = factory#add_submenu (s_ "Help") in
  81
  82     window#add_accel_group accel_group;
  83
  84     (* File menu. *)
  85     let factory = new GMenu.factory file_menu ~accel_group in
  86     let open_item = factory#add_item (s_ "Open connection ...")
  87       ~key:GdkKeysyms._O in
  88     ignore (factory#add_separator ());
  89     let quit_item = factory#add_item (s_ "Quit") ~key:GdkKeysyms._Q in
  90
  91     ignore (open_item#connect#activate
  92               ~callback:(Vc_connection_dlg.open_connection window));
  93
  94     (* Help menu. *)
  95     let factory = new GMenu.factory help_menu ~accel_group in
  96     let help_item = factory#add_item (s_ "Help") in
  97     let help_about_item = factory#add_item (s_ "About ...") in
  98
  99     ignore (help_about_item#connect#activate ~callback:help_about);
 100
 101     quit_item in
 102
 103   (* The toolbar. *)
 104   let toolbar = GButton.toolbar ~packing:vbox#pack () in
 105
 106   (* The treeview. *)
 107   let (tree, model, columns, initial_state) =
 108     Vc_connections.make_treeview
 109       ~packing:(vbox#pack ~expand:true ~fill:true) () in
 110
 111   (* Add buttons to the toolbar (requires the treeview to
 112    * have been made above).
 113    *)
 114   let () =
 115     let connect_button_menu = GMenu.menu () in
 116     let connect_button =
 117       GButton.menu_tool_button
 118         ~label:(s_ "Connect ...") ~stock:`CONNECT
 119         ~menu:connect_button_menu
 120         ~packing:toolbar#insert () in
 121     ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
 122     let open_button =
 123       GButton.tool_button ~label:(s_ "Details") ~stock:`OPEN
 124         ~packing:toolbar#insert () in
 125     ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
 126     let start_button =
 127       GButton.tool_button ~label:(s_ "Start") ~stock:`ADD
 128         ~packing:toolbar#insert () in
 129     let pause_button =
 130       GButton.tool_button ~label:(s_ "Pause") ~stock:`MEDIA_PAUSE
 131         ~packing:toolbar#insert () in
 132     let resume_button =
 133       GButton.tool_button ~label:(s_ "Resume") ~stock:`MEDIA_PLAY
 134         ~packing:toolbar#insert () in
 135     ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
 136     let shutdown_button =
 137       GButton.tool_button ~label:(s_ "Shutdown") ~stock:`STOP
 138         ~packing:toolbar#insert () in
 139
 140     (* Set callbacks for the toolbar buttons. *)
 141     ignore (connect_button#connect#clicked
 142               ~callback:(Vc_connection_dlg.open_connection window));
 143     ignore (open_button#connect#clicked
 144               ~callback:(open_domain_details tree model columns));
 145     ignore (start_button#connect#clicked
 146               ~callback:(start_domain tree model columns));
 147     ignore (pause_button#connect#clicked
 148               ~callback:(pause_domain tree model columns));
 149     ignore (resume_button#connect#clicked
 150               ~callback:(resume_domain tree model columns));
 151     ignore (shutdown_button#connect#clicked
 152               ~callback:(shutdown_domain tree model columns));
 153
 154     (* Set a menu on the connect menu-button. *)
 155     let () =
 156       let factory = new GMenu.factory connect_button_menu (*~accel_group*) in
 157       let local_xen = factory#add_item (s_ "Local Xen") in
 158       let local_qemu = factory#add_item (s_ "Local QEMU/KVM") in
 159       ignore (factory#add_separator ());
 160       let open_dialog = factory#add_item (s_ "Connect to ...") in
 161       ignore (local_xen#connect#activate
 162                 ~callback:Vc_connection_dlg.open_local_xen);
 163       ignore (local_qemu#connect#activate
 164                 ~callback:Vc_connection_dlg.open_local_qemu);
 165       ignore (open_dialog#connect#activate
 166                 ~callback:(Vc_connection_dlg.open_connection window)) in
 167     () in
 168
 169   (* Make a timeout function which is called once per second. *)
 170   let state = ref initial_state in
 171   let callback () =
 172     (* Gc.compact is generally not safe in lablgtk programs, but
 173      * is explicitly allowed in timeouts (see lablgtk README).
 174      * This ensures memory is compacted regularly, but is also an
 175      * excellent way to catch memory bugs in the ocaml libvirt bindings.
 176      *)
 177     Gc.compact ();
 178
 179     (* Ugh: Bug in lablgtk causes a segfault if a timeout raises an
 180      * exception.  Catch and print exceptions instead.
 181      *)
 182     (try state := Vc_connections.repopulate tree model columns !state
 183      with exn -> prerr_endline (Printexc.to_string exn));
 184
 185     true
 186   in
 187   let timeout_id = GMain.Timeout.add ~ms:1000 ~callback in
 188
 189   (* Quit. *)
 190   let quit _ =
 191     GMain.Timeout.remove timeout_id;
 192     GMain.quit ();
 193     false
 194   in
 195
 196   ignore (window#connect#destroy ~callback:GMain.quit);
 197   ignore (window#event#connect#delete ~callback:quit);
 198   ignore (quit_item#connect#activate
 199             ~callback:(fun () -> ignore (quit ()); ()));
 200
 201   (* Display the window. *)
 202   window#show ()