1 (* virt-ctrl: A graphical management tool.
2 (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
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.
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.
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.
22 let title = "Virtual Control"
24 let utf8_copyright = "\194\169"
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;
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)
44 (* Catch any exception and throw up a dialog. *)
46 (* A nicer exception printing function. *)
47 let string_of_exn = function
48 | Libvirt.Virterror err ->
49 "Virtualisation error: " ^ (Libvirt.Virterror.to_string err)
51 | exn -> Printexc.to_string exn
53 GtkSignal.user_handler :=
55 let label = string_of_exn exn in
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
63 (* Open connection dialog.
64 * This should be a lot more sophisticated. XXX
66 let open_connection () =
67 let title = "Open connection to hypervisor" in
69 GToolbox.input_string ~title ~text:"xen:///" ~ok:"Open" "Connection:" in
72 | Some uri -> Vc_connections.open_connection uri
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
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
89 let factory = new GMenu.factory file_menu ~accel_group in
90 let open_item = factory#add_item "Open connection ..."
92 ignore (factory#add_separator ());
93 let quit_item = factory#add_item "Quit" ~key:GdkKeysyms._Q in
95 ignore (open_item#connect#activate ~callback:open_connection);
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
102 ignore (help_about_item#connect#activate ~callback:help_about);
105 let toolbar = GButton.toolbar ~packing:vbox#pack () in
107 GButton.tool_button ~label:"Connect ..." ~stock:`CONNECT
108 ~packing:toolbar#insert () in
109 ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
111 GButton.tool_button ~label:"Details" ~stock:`OPEN
112 ~packing:toolbar#insert () in
113 ignore (GButton.separator_tool_item ~packing:toolbar#insert ());
115 GButton.tool_button ~label:"Start" ~stock:`ADD
116 ~packing:toolbar#insert () in
118 GButton.tool_button ~label:"Pause" ~stock:`MEDIA_PAUSE
119 ~packing:toolbar#insert () in
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
128 let (tree, model, columns, initial_state) =
129 Vc_connections.make_treeview
130 ~packing:(vbox#pack ~expand:true ~fill:true) () in
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));
145 (* Make a timeout function which is called once per second. *)
146 let state = ref initial_state in
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.
155 (* Ugh: Bug in lablgtk causes a segfault if a timeout raises an
156 * exception. Catch and print exceptions instead.
158 (try state := Vc_connections.repopulate tree model columns !state
159 with exn -> prerr_endline (Printexc.to_string exn));
163 let timeout_id = GMain.Timeout.add ~ms:1000 ~callback in
167 GMain.Timeout.remove timeout_id;
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 ()); ()));
177 window#add_accel_group accel_group;
179 (* Display the window. *)