Add a .gitignore file for git.
[virt-ctrl.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 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 (* Set up a global exception handler to catch any exception and throw
49  * up a dialog.
50  *)
51 let () =
52   (* A nicer exception printing function. *)
53   let string_of_exn = function
54     | Libvirt.Virterror err ->
55         s_ "Virtualisation error" ^ ": " ^ (Libvirt.Virterror.to_string err)
56     | Failure msg -> msg
57     | exn -> Printexc.to_string exn
58   in
59   GtkSignal.user_handler :=
60     fun exn ->
61       let label = string_of_exn exn in
62       prerr_endline label;
63       let title = s_ "Error" in
64       let icon = GMisc.image () in
65       icon#set_stock `DIALOG_ERROR;
66       icon#set_icon_size `DIALOG;
67       GToolbox.message_box ~title ~icon label
68
69 let rec make
70     ~start_domain ~pause_domain ~resume_domain ~shutdown_domain
71     ~open_domain_details =
72   (* Create the main window. *)
73   let window = GWindow.window ~width:800 ~height:600 ~title () in
74   let vbox = GPack.vbox ~packing:window#add () in
75
76   (* Menu bar. *)
77   let quit_item, install_item =
78     let menubar = GMenu.menu_bar ~packing:vbox#pack () in
79     let factory = new GMenu.factory menubar in
80     let accel_group = factory#accel_group in
81     let file_menu = factory#add_submenu (s_ "File") in
82     let help_menu = factory#add_submenu (s_ "Help") in
83
84     window#add_accel_group accel_group;
85
86     (* File menu. *)
87     let factory = new GMenu.factory file_menu ~accel_group in
88     let open_item = factory#add_item (s_ "Open connection ...")
89       ~key:GdkKeysyms._O in
90     ignore (factory#add_separator ());
91     let install_item = factory#add_item (s_ "Install new guest ...")
92       ~key:GdkKeysyms._N in
93     ignore (factory#add_separator ());
94     let quit_item = factory#add_item (s_ "Quit") ~key:GdkKeysyms._Q in
95
96     ignore (open_item#connect#activate
97               ~callback:(Vc_connection_dlg.open_connection window));
98     (* Help menu. *)
99     let factory = new GMenu.factory help_menu ~accel_group in
100     let help_item = factory#add_item (s_ "Help") in
101     let help_about_item = factory#add_item (s_ "About ...") in
102
103     ignore (help_about_item#connect#activate ~callback:help_about);
104
105     quit_item, install_item in
106
107   (* The toolbar. *)
108   let toolbar = GButton.toolbar ~packing:vbox#pack () in
109
110   (* The treeview. *)
111   let (tree, model, columns, initial_state) =
112     Vc_connections.make_treeview
113       ~packing:(vbox#pack ~expand:true ~fill:true) () in
114
115   (* Wire up the install item (requires the treeview for selection). *)
116   ignore (install_item#connect#activate
117             ~callback:(
118               fun () ->
119                 let conn_id = get_conn_id tree model columns in
120                 match conn_id with
121                 | None -> ()            (* nothing selected *)
122                 | Some conn_id ->       (* connection ID selected *)
123                     Vc_install_dlg.install_guest window conn_id ()
124             )
125          );
126
127   (* Add buttons to the toolbar (requires the treeview to
128    * have been made above).
129    *)
130   let () =
131     let connect_button_menu = GMenu.menu () in
132     let connect_button =
133       GButton.menu_tool_button
134         ~label:(s_ "Connect ...") ~stock:`CONNECT
135         ~menu:connect_button_menu
136         ~packing:toolbar#insert () in
137     ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
138     let open_button =
139       GButton.tool_button ~label:(s_ "Details") ~stock:`OPEN
140         ~packing:toolbar#insert () in
141     ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
142     let start_button =
143       GButton.tool_button ~label:(s_ "Start") ~stock:`ADD
144         ~packing:toolbar#insert () in
145     let pause_button =
146       GButton.tool_button ~label:(s_ "Pause") ~stock:`MEDIA_PAUSE
147         ~packing:toolbar#insert () in
148     let resume_button =
149       GButton.tool_button ~label:(s_ "Resume") ~stock:`MEDIA_PLAY
150         ~packing:toolbar#insert () in
151     ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
152     let shutdown_button =
153       GButton.tool_button ~label:(s_ "Shutdown") ~stock:`STOP
154         ~packing:toolbar#insert () in
155
156     (* Set callbacks for the toolbar buttons. *)
157     ignore (connect_button#connect#clicked
158               ~callback:(Vc_connection_dlg.open_connection window));
159     ignore (open_button#connect#clicked
160               ~callback:(open_domain_details tree model columns));
161     ignore (start_button#connect#clicked
162               ~callback:(start_domain tree model columns));
163     ignore (pause_button#connect#clicked
164               ~callback:(pause_domain tree model columns));
165     ignore (resume_button#connect#clicked
166               ~callback:(resume_domain tree model columns));
167     ignore (shutdown_button#connect#clicked
168               ~callback:(shutdown_domain tree model columns));
169
170     (* Set a menu on the connect menu-button. *)
171     let () =
172       let factory = new GMenu.factory connect_button_menu (*~accel_group*) in
173       let local_xen = factory#add_item (s_ "Local Xen") in
174       let local_qemu = factory#add_item (s_ "Local QEMU/KVM") in
175       ignore (factory#add_separator ());
176       let open_dialog = factory#add_item (s_ "Connect to ...") in
177       ignore (local_xen#connect#activate
178                 ~callback:Vc_connection_dlg.open_local_xen);
179       ignore (local_qemu#connect#activate
180                 ~callback:Vc_connection_dlg.open_local_qemu);
181       ignore (open_dialog#connect#activate
182                 ~callback:(Vc_connection_dlg.open_connection window)) in
183     () in
184
185   (* Make a timeout function which is called once per second. *)
186   let state = ref initial_state in
187   let callback () =
188     (* Gc.compact is generally not safe in lablgtk programs, but
189      * is explicitly allowed in timeouts (see lablgtk README).
190      * This ensures memory is compacted regularly, but is also an
191      * excellent way to catch memory bugs in the ocaml libvirt bindings.
192      *)
193     Gc.compact ();
194
195     (* Ugh: Bug in lablgtk causes a segfault if a timeout raises an
196      * exception.  Catch and print exceptions instead.
197      *)
198     (try state := Vc_connections.repopulate tree model columns !state
199      with exn -> prerr_endline (Printexc.to_string exn));
200
201     true
202   in
203   let timeout_id = GMain.Timeout.add ~ms:1000 ~callback in
204
205   (* Quit. *)
206   let quit _ =
207     GMain.Timeout.remove timeout_id;
208     GMain.quit ();
209     false
210   in
211
212   ignore (window#connect#destroy ~callback:GMain.quit);
213   ignore (window#event#connect#delete ~callback:quit);
214   ignore (quit_item#connect#activate
215             ~callback:(fun () -> ignore (quit ()); ()));
216
217   (* Display the window. *)
218   window#show ()
219
220 (* Get the selected connection ID if there is one or return None. *)
221 and get_conn_id (tree : GTree.view) (model : GTree.tree_store)
222     (columns : Vc_connections.columns) =
223   let path, _ = tree#get_cursor () in
224   match path with
225   | None -> None                        (* No row at all selected. *)
226   | Some path ->
227       let row = model#get_iter path in
228       let (_, _, _, _, _, col_id) = columns in
229       (* Visit parent to get the connid.
230        * If this returns None, then this is already a top-level row
231        * (ie. a connection).
232        *)
233       match model#iter_parent row with
234       | None ->
235           let connid = model#get ~row ~column:col_id in
236           Some connid
237       | Some parent ->
238           try
239             let connid = model#get ~row:parent ~column:col_id in
240             Some connid
241           with
242             (* Domain or connection disappeared under us. *)
243           | Not_found -> None
244           | Failure msg ->
245               prerr_endline msg;
246               None
247           | Libvirt.Virterror err ->
248               prerr_endline (Libvirt.Virterror.to_string err);
249               None