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