2 * Copyright (C) 2010 Red Hat Inc.
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 2 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License along
15 * with this program; if not, write to the Free Software Foundation, Inc.,
16 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
25 let (//) = Filename.concat
28 type display_state = {
29 window : GWindow.window;
30 throbber_busy : unit -> unit;
31 throbber_idle : unit -> unit;
32 set_statusbar : string -> unit;
33 clear_statusbar : unit -> unit;
34 set_vmlist : string list -> unit;
35 clear_vmlist : unit -> unit;
36 clear_notebook : unit -> unit;
37 filesystem : GPack.box;
38 notebook : GPack.notebook;
41 let rec open_main_window () =
42 let title = "Guest Filesystem Browser" in
43 let window = GWindow.window ~width:800 ~height:600 ~title () in
44 let vbox = GPack.vbox ~packing:window#add () in
47 let menubar = GMenu.menu_bar ~packing:vbox#pack () in
48 let factory = new GMenu.factory menubar in
49 let accel_group = factory#accel_group in
50 let connect_menu = factory#add_submenu "_Connect" in
52 let factory = new GMenu.factory connect_menu ~accel_group in
53 let connect_item = factory#add_item "_Connect to libvirt ..." in
54 let open_item = factory#add_item "_Open disk image ..." ~key:GdkKeysyms._O in
55 ignore (factory#add_separator ());
56 let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
59 let quit _ = GMain.quit (); false in
60 ignore (window#connect#destroy ~callback:GMain.quit);
61 ignore (window#event#connect#delete ~callback:quit);
62 ignore (quit_item#connect#activate
63 ~callback:(fun () -> ignore (quit ()); ()));
65 (* Top status area. *)
66 let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in
67 hbox#pack (mklabel "Guest: ");
70 let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in
71 let set_vmlist names =
72 let combo, (model, column) = vmcombo in
76 let row = model#append () in
77 model#set ~row ~column name
80 let clear_vmlist () = set_vmlist [] in
82 (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *)
83 let static = Throbber.static () in
84 (*let animation = Throbber.animation () in*)
86 GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in
87 let throbber_busy () =
88 (*throbber#set_pixbuf animation*)
89 (* Workaround because no binding for GdkPixbufAnimation: *)
90 let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in
91 throbber#set_file file
92 and throbber_idle () =
93 throbber#set_pixbuf static
96 (* Tabbed pane ("notebook") filling the main window. *)
97 let nb = GPack.notebook ~scrollable:true
98 ~packing:(vbox#pack ~expand:true ~fill:true) () in
99 let filesystem = GPack.vbox () in
100 filesystem#add (intro_label () :> GObj.widget);
101 ignore (nb#append_page
102 ~tab_label:(mklabel "Filesystem") (filesystem :> GObj.widget));
103 let clear_notebook () =
105 (* Remove all tabs except the first ("Filesystem") tab ... *)
106 List.iter nb#remove (List.tl nb#all_children);
107 (* ... and clear out the filesystem tab. *)
108 List.iter filesystem#remove filesystem#all_children
111 (* Status bar at the bottom of the screen. *)
113 let statusbar = GMisc.statusbar ~packing:vbox#pack () in
114 let context = statusbar#new_context ~name:"Standard" in
115 ignore (context#push title);
118 ignore (context#push msg)
120 let clear_statusbar () = set_statusbar "" in
123 window#add_accel_group accel_group;
125 (* display_state which is threaded through all the other callbacks,
126 * allowing callbacks to update the window.
130 throbber_busy = throbber_busy; throbber_idle = throbber_idle;
131 set_statusbar = set_statusbar; clear_statusbar = clear_statusbar;
132 set_vmlist = set_vmlist; clear_vmlist = clear_vmlist;
133 clear_notebook = clear_notebook;
134 filesystem = filesystem; notebook = nb;
137 (* Set up some callbacks which require access to the display_state. *)
139 let combo, (model, column) = vmcombo in
140 combo#connect#changed
143 match combo#active_iter with
146 let name = model#get ~row ~column in
147 ds.set_statusbar (sprintf "Opening %s ..." name);
148 ds.clear_notebook ();
149 Slave.open_domain name (opened_domain ds))
152 ignore (connect_item#connect#activate ~callback:(connect_dialog ds));
153 ignore (open_item#connect#activate ~callback:(open_dialog ds));
155 (* Return the display state. *)
158 (* Convenience function to make a label containing some text. It is
159 * returned as a generic widget.
162 (GMisc.label ~text () :> GObj.widget)
164 (* This is called in the main thread whenever a command fails in the
165 * slave thread. The command queue has been cleared before this is
166 * called, so our job here is to reset the main window, and if
167 * necessary to turn the exception into an error message.
170 let title = "Error" in
171 let msg = Printexc.to_string exn in
172 debug "thread id %d: failure hook: %s" (Thread.id (Thread.self ())) msg;
173 let icon = GMisc.image () in
174 icon#set_stock `DIALOG_ERROR;
175 icon#set_icon_size `DIALOG;
176 GToolbox.message_box ~title ~icon msg
178 (* This is called in the main thread when we've connected to libvirt. *)
179 and connected ds uri () =
180 debug "thread id %d: connected callback" (Thread.id (Thread.self ()));
183 | None -> "Connected to libvirt"
184 | Some uri -> sprintf "Connected to %s" uri in
185 ds.set_statusbar msg;
186 Slave.get_domains (got_domains ds)
188 (* This is called in the main thread when we've got the list of domains. *)
189 and got_domains ds doms =
190 let doms = List.map (fun { Slave.dom_name = name } -> name) doms in
191 debug "thread id %d: got_domains callback: (%s)"
192 (Thread.id (Thread.self ())) (String.concat " " doms);
195 (* This callback indicates that the domain was opened successfully. *)
196 and opened_domain ds rw =
197 debug "thread id %d: opened_domain callback" (Thread.id (Thread.self ()));
200 (* This callback indicates that local disk image(s) were opened successfully.*)
201 and opened_images ds rw =
202 debug "thread id %d: opened_images callback" (Thread.id (Thread.self ()));
206 ds.clear_statusbar ();
207 ds.clear_notebook ();
209 (* Get the list of mountable filesystems. *)
210 Slave.get_volumes (got_volume ds rw)
212 (* This callback is called once for each mountable filesystem that is
215 and got_volume ds rw vol =
216 let dev = vol.Slave.vol_device in
217 debug "thread id %d: got_volume callback: %s"
218 (Thread.id (Thread.self ())) dev;
220 (* What's on the tab. *)
222 match vol.Slave.vol_label with
223 | "" -> sprintf "%s" dev
224 | label -> sprintf "%s (%s)" dev label in
226 (* What's on the notebook page. *)
228 let vbox = GPack.vbox () in
230 (* VFS stats table. *)
232 (* For calculations, see libguestfs/tools/virt-df. *)
233 let st = vol.Slave.vol_statvfs in
234 let factor = st.G.bsize /^ 1024L in
236 (* Right-aligned label with width, for stats table. *)
238 let markup = "<b>" ^ text ^ "</b>" in
239 let label = GMisc.label ~markup ~xalign:1. () in
240 label#set_width_chars 12;
241 (label :> GObj.widget)
243 let label = GMisc.label ~text ~selectable:true ~xalign:1. () in
244 label#set_width_chars 12;
245 (label :> GObj.widget)
248 let stats = GPack.table ~columns:4 ~rows:5
249 ~homogeneous:true ~col_spacings:4 ~row_spacings:4
250 ~packing:vbox#pack () in
251 stats#attach ~top:0 ~left:0 (mklabelh "1K-blocks");
252 stats#attach ~top:0 ~left:1 (mklabelh "Used");
253 stats#attach ~top:0 ~left:2 (mklabelh "Available");
254 stats#attach ~top:0 ~left:3 (mklabelh "Use%");
255 let blocks = st.G.blocks *^ factor in
256 stats#attach ~top:1 ~left:0 (mklabelr (sprintf "%Ld" blocks));
257 let used = (st.G.blocks -^ st.G.bfree) *^ factor in
258 stats#attach ~top:1 ~left:1 (mklabelr (sprintf "%Ld" used));
259 let available = st.G.bavail *^ factor in
260 stats#attach ~top:1 ~left:2 (mklabelr (sprintf "%Ld" available));
261 stats#attach ~top:1 ~left:3
262 (mklabelr (sprintf "%Ld%%" (100L -^ 100L *^ st.G.bfree /^ st.G.blocks)));
263 stats#attach ~top:2 ~left:0 (mklabelr ("= " ^ human_size_1k blocks));
264 stats#attach ~top:2 ~left:1 (mklabelr ("= " ^ human_size_1k used));
265 stats#attach ~top:2 ~left:2 (mklabelr ("= " ^ human_size_1k available));
266 stats#attach ~top:3 ~left:0 (mklabelh "Inodes");
267 stats#attach ~top:3 ~left:1 (mklabelh "IUsed");
268 stats#attach ~top:3 ~left:2 (mklabelh "IFree");
269 stats#attach ~top:3 ~left:3 (mklabelh "IUse%");
270 stats#attach ~top:4 ~left:0 (mklabelr (sprintf "%Ld" st.G.files));
271 stats#attach ~top:4 ~left:1
272 (mklabelr (sprintf "%Ld" (st.G.files -^ st.G.ffree)));
273 stats#attach ~top:4 ~left:2 (mklabelr (sprintf "%Ld" st.G.ffree));
274 stats#attach ~top:4 ~left:3
275 (mklabelr (sprintf "%Ld%%" (100L -^ 100L *^ st.G.ffree /^ st.G.files)));
279 (* Left- and right-aligned labels, for info table. *)
281 let label = GMisc.label ~text ~xalign:1. () in
282 label#set_width_chars 9;
283 (label :> GObj.widget)
285 let label = GMisc.label ~text ~selectable:true ~xalign:0. () in
286 (label :> GObj.widget)
289 let info = GPack.table ~columns:4 ~rows:2
290 ~col_spacings:4 ~row_spacings:4
291 ~packing:vbox#pack () in
292 info#attach ~top:0 ~left:0 (mklabelr "FS label:");
293 info#attach ~top:0 ~left:1 (mklabell vol.Slave.vol_label);
294 info#attach ~top:1 ~left:0 (mklabelr "FS type:");
295 info#attach ~top:1 ~left:1 (mklabell vol.Slave.vol_type);
296 info#attach ~top:0 ~left:2 (mklabelr "FS UUID:");
297 info#attach ~top:0 ~left:3 (mklabell vol.Slave.vol_uuid);
298 info#attach ~top:1 ~left:2 (mklabelr "Device:");
299 info#attach ~top:1 ~left:3 (mklabell dev);
302 let sw = GBin.scrolled_window
303 ~packing:(vbox#pack ~expand:true ~fill:true)
304 ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
305 let view = Filetree.filetree dev rw in
306 sw#add (view :> GObj.widget);
310 ds.notebook#append_page ~tab_label:(mklabel tab) (page :> GObj.widget)
313 (* Open the connect to libvirt dialog. *)
314 and connect_dialog ds () =
315 debug "connect menu";
316 (*ds.clear_notebook ();*)
317 failwith "XXX CONNECT DLG NOT IMPL"
319 (* Open the disk images dialog. *)
320 and open_dialog ds () =
322 (*ds.clear_notebook ();*)
323 failwith "XXX OPEN DLG NOT IMPL"
325 (* The introductory text which appears in the tabbed notebook to
326 * tell the user how to start. XXX We should add images.
330 sprintf "Open a disk image (Connect %s Open disk image), connect to libvirt (Connect %s Connect to libvirt), or choose a guest from the \"Guest\" menu above."
331 utf8_rarrow utf8_rarrow in
332 let label = GMisc.label ~text () in
333 label#set_line_wrap true;
336 let run_cli_request ds = function
337 | Cmdline.Empty_window -> ()
338 | Cmdline.Connect_to_libvirt uri ->
339 Slave.connect uri (connected ds uri)
340 | Cmdline.Open_disk_image images ->
341 Slave.open_images images (opened_images ds)