4fd82c947212f16f718ab958ee64d7a5ce737391
[virt-top.git] / 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 let make ~open_connection
64     ~start_domain ~pause_domain ~resume_domain ~shutdown_domain =
65   (* Create the main window. *)
66   let window = GWindow.window ~width:800 ~height:600 ~title () in
67   let vbox = GPack.vbox ~packing:window#add () in
68
69   (* Menu bar. *)
70   let menubar = GMenu.menu_bar ~packing:vbox#pack () in
71   let factory = new GMenu.factory menubar in
72   let accel_group = factory#accel_group in
73   let file_menu = factory#add_submenu "File" in
74   let help_menu = factory#add_submenu "Help" in
75
76   (* File menu. *)
77   let factory = new GMenu.factory file_menu ~accel_group in
78   let open_item = factory#add_item "Open connection ..."
79     ~key:GdkKeysyms._O in
80   ignore (factory#add_separator ());
81   let quit_item = factory#add_item "Quit" ~key:GdkKeysyms._Q in
82
83   ignore (open_item#connect#activate ~callback:open_connection);
84
85   (* Help menu. *)
86   let factory = new GMenu.factory help_menu ~accel_group in
87   let help_item = factory#add_item "Help" in
88   let help_about_item = factory#add_item "About ..." in
89
90   ignore (help_about_item#connect#activate ~callback:help_about);
91
92   (* The toolbar. *)
93   let toolbar = GButton.toolbar ~packing:vbox#pack () in
94   let connect_button =
95     GButton.tool_button ~label:"Connect ..." ~stock:`CONNECT
96       ~packing:toolbar#insert () in
97   let start_button =
98     GButton.tool_button ~label:"Start" ~stock:`ADD
99       ~packing:toolbar#insert () in
100   let pause_button =
101     GButton.tool_button ~label:"Pause" ~stock:`MEDIA_PAUSE
102       ~packing:toolbar#insert () in
103   let resume_button =
104     GButton.tool_button ~label:"Resume" ~stock:`MEDIA_PLAY
105       ~packing:toolbar#insert () in
106   let shutdown_button =
107     GButton.tool_button ~label:"Shutdown" ~stock:`STOP
108       ~packing:toolbar#insert () in
109   ignore (connect_button#connect#clicked ~callback:open_connection);
110
111   (* The treeview. *)
112   let (tree, model, columns, initial_state) =
113     Vc_connections.make_treeview
114       ~packing:(vbox#pack ~expand:true ~fill:true) () in
115
116   ignore (start_button#connect#clicked
117             ~callback:(start_domain tree model columns));
118   ignore (pause_button#connect#clicked
119             ~callback:(pause_domain tree model columns));
120   ignore (resume_button#connect#clicked
121             ~callback:(resume_domain tree model columns));
122   ignore (shutdown_button#connect#clicked
123             ~callback:(shutdown_domain tree model columns));
124
125   (* Make a timeout function which is called once per second. *)
126   let state = ref initial_state in
127   let callback () =
128     (* Gc.compact is generally not safe in lablgtk programs, but
129      * is explicitly allowed in timeouts (see lablgtk README).
130      * This ensures memory is compacted regularly, but is also an
131      * excellent way to catch memory bugs in the ocaml libvirt bindings.
132      *)
133     Gc.compact ();
134
135     (* Ugh: Bug in lablgtk causes a segfault if a timeout raises an
136      * exception.  Catch and print exceptions instead.
137      *)
138     (try state := Vc_connections.repopulate tree model columns !state
139      with exn -> prerr_endline (Printexc.to_string exn));
140
141     true
142   in
143   let timeout_id = GMain.Timeout.add ~ms:1000 ~callback in
144
145   (* Quit. *)
146   let quit _ =
147     GMain.Timeout.remove timeout_id;
148     GMain.Main.quit ();
149     false
150   in
151
152   ignore (window#connect#destroy ~callback:GMain.quit);
153   ignore (window#event#connect#delete ~callback:quit);
154   ignore (quit_item#connect#activate
155             ~callback:(fun () -> ignore (quit ()); ()));
156
157   window#add_accel_group accel_group;
158
159   (* Display the window. *)
160   window#show ()