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:700 ~height:700 ~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.discard_command_queue ();
150 Slave.open_domain name (opened_domain ds))
153 ignore (connect_item#connect#activate ~callback:(connect_dialog ds));
154 ignore (open_item#connect#activate ~callback:(open_dialog ds));
156 (* Return the display state. *)
159 (* Convenience function to make a label containing some text. It is
160 * returned as a generic widget.
163 (GMisc.label ~text () :> GObj.widget)
165 (* This is called in the main thread whenever a command fails in the
166 * slave thread. The command queue has been cleared before this is
167 * called, so our job here is to reset the main window, and if
168 * necessary to turn the exception into an error message.
171 let title = "Error" in
172 let msg = Printexc.to_string exn in
173 debug "thread id %d: failure hook: %s" (Thread.id (Thread.self ())) msg;
174 let icon = GMisc.image () in
175 icon#set_stock `DIALOG_ERROR;
176 icon#set_icon_size `DIALOG;
177 GToolbox.message_box ~title ~icon msg
179 (* This is called in the main thread when we've connected to libvirt. *)
180 and connected ds uri () =
181 debug "thread id %d: connected callback" (Thread.id (Thread.self ()));
184 | None -> "Connected to libvirt"
185 | Some uri -> sprintf "Connected to %s" uri in
186 ds.set_statusbar msg;
187 Slave.get_domains (got_domains ds)
189 (* This is called in the main thread when we've got the list of domains. *)
190 and got_domains ds doms =
191 let doms = List.map (fun { Slave.dom_name = name } -> name) doms in
192 debug "thread id %d: got_domains callback: (%s)"
193 (Thread.id (Thread.self ())) (String.concat " " doms);
196 (* This callback indicates that the domain was opened successfully. *)
197 and opened_domain ds rw =
198 debug "thread id %d: opened_domain callback" (Thread.id (Thread.self ()));
201 (* This callback indicates that local disk image(s) were opened successfully.*)
202 and opened_images ds rw =
203 debug "thread id %d: opened_images callback" (Thread.id (Thread.self ()));
207 ds.clear_statusbar ();
208 ds.clear_notebook ();
210 (* Get the list of mountable filesystems. *)
211 Slave.get_volumes (got_volume ds rw)
213 (* This callback is called once for each mountable filesystem that is
216 and got_volume ds rw vol =
217 let dev = vol.Slave.vol_device in
218 debug "thread id %d: got_volume callback: %s"
219 (Thread.id (Thread.self ())) dev;
221 (* What's on the tab. *)
223 match vol.Slave.vol_label with
224 | "" -> sprintf "%s" dev
225 | label -> sprintf "%s (%s)" dev label in
227 (* What's on the notebook page. *)
229 let vbox = GPack.vbox () in
231 (* VFS stats table. *)
233 (* For calculations, see libguestfs/tools/virt-df. *)
234 let st = vol.Slave.vol_statvfs in
235 let factor = st.G.bsize /^ 1024L in
237 (* Right-aligned label with width, for stats table. *)
239 let markup = "<b>" ^ text ^ "</b>" in
240 let label = GMisc.label ~markup ~xalign:1. () in
241 label#set_width_chars 12;
242 (label :> GObj.widget)
244 let label = GMisc.label ~text ~selectable:true ~xalign:1. () in
245 label#set_width_chars 12;
246 (label :> GObj.widget)
249 let stats = GPack.table ~columns:4 ~rows:5
250 ~homogeneous:true ~col_spacings:4 ~row_spacings:4
251 ~packing:vbox#pack () in
252 stats#attach ~top:0 ~left:0 (mklabelh "1K-blocks");
253 stats#attach ~top:0 ~left:1 (mklabelh "Used");
254 stats#attach ~top:0 ~left:2 (mklabelh "Available");
255 stats#attach ~top:0 ~left:3 (mklabelh "Use%");
256 let blocks = st.G.blocks *^ factor in
257 stats#attach ~top:1 ~left:0 (mklabelr (sprintf "%Ld" blocks));
258 let used = (st.G.blocks -^ st.G.bfree) *^ factor in
259 stats#attach ~top:1 ~left:1 (mklabelr (sprintf "%Ld" used));
260 let available = st.G.bavail *^ factor in
261 stats#attach ~top:1 ~left:2 (mklabelr (sprintf "%Ld" available));
262 stats#attach ~top:1 ~left:3
263 (mklabelr (sprintf "%Ld%%" (100L -^ 100L *^ st.G.bfree /^ st.G.blocks)));
264 stats#attach ~top:2 ~left:0 (mklabelr ("= " ^ human_size_1k blocks));
265 stats#attach ~top:2 ~left:1 (mklabelr ("= " ^ human_size_1k used));
266 stats#attach ~top:2 ~left:2 (mklabelr ("= " ^ human_size_1k available));
267 stats#attach ~top:3 ~left:0 (mklabelh "Inodes");
268 stats#attach ~top:3 ~left:1 (mklabelh "IUsed");
269 stats#attach ~top:3 ~left:2 (mklabelh "IFree");
270 stats#attach ~top:3 ~left:3 (mklabelh "IUse%");
271 stats#attach ~top:4 ~left:0 (mklabelr (sprintf "%Ld" st.G.files));
272 stats#attach ~top:4 ~left:1
273 (mklabelr (sprintf "%Ld" (st.G.files -^ st.G.ffree)));
274 stats#attach ~top:4 ~left:2 (mklabelr (sprintf "%Ld" st.G.ffree));
275 stats#attach ~top:4 ~left:3
276 (mklabelr (sprintf "%Ld%%" (100L -^ 100L *^ st.G.ffree /^ st.G.files)));
280 (* Left- and right-aligned labels, for info table. *)
282 let label = GMisc.label ~text ~xalign:1. () in
283 label#set_width_chars 9;
284 (label :> GObj.widget)
286 let label = GMisc.label ~text ~selectable:true ~xalign:0. () in
287 (label :> GObj.widget)
290 let info = GPack.table ~columns:4 ~rows:2
291 ~col_spacings:4 ~row_spacings:4
292 ~packing:vbox#pack () in
293 info#attach ~top:0 ~left:0 (mklabelr "FS label:");
294 info#attach ~top:0 ~left:1 (mklabell vol.Slave.vol_label);
295 info#attach ~top:1 ~left:0 (mklabelr "FS type:");
296 info#attach ~top:1 ~left:1 (mklabell vol.Slave.vol_type);
297 info#attach ~top:0 ~left:2 (mklabelr "FS UUID:");
298 info#attach ~top:0 ~left:3 (mklabell vol.Slave.vol_uuid);
299 info#attach ~top:1 ~left:2 (mklabelr "Device:");
300 info#attach ~top:1 ~left:3 (mklabell dev);
303 let sw = GBin.scrolled_window
304 ~packing:(vbox#pack ~expand:true ~fill:true)
305 ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
306 let view = Filetree.filetree dev rw in
307 sw#add (view :> GObj.widget);
311 ds.notebook#append_page ~tab_label:(mklabel tab) (page :> GObj.widget)
314 (* Open the connect to libvirt dialog. *)
315 and connect_dialog ds () =
316 debug "connect menu";
317 (*ds.clear_notebook ();*)
318 (*Slave.discard_command_queue ();*)
319 (* XXX NOT IMPL XXX *)
322 (* Open the disk images dialog. *)
323 and open_dialog ds () =
325 (*ds.clear_notebook ();*)
326 (*Slave.discard_command_queue ();*)
327 (* XXX NOT IMPL XXX *)
330 (* The introductory text which appears in the tabbed notebook to
331 * tell the user how to start. XXX We should add images.
335 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."
336 utf8_rarrow utf8_rarrow in
337 let label = GMisc.label ~text () in
338 label#set_line_wrap true;
341 let run_cli_request ds = function
342 | Cmdline.Empty_window -> ()
343 | Cmdline.Connect_to_libvirt uri ->
344 Slave.connect uri (connected ds uri)
345 | Cmdline.Open_disk_image images ->
346 Slave.open_images images (opened_images ds)