window.ml

   1 (* Guestfs Browser.
   2  * Copyright (C) 2010 Red Hat Inc.
   3  *
   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.
   8  *
   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.
  13  *
  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.
  17  *)
  18
  19 open Printf
  20
  21 open Utils
  22
  23 module G = Guestfs
  24
  25 let (//) = Filename.concat
  26
  27 (* Display state. *)
  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;
  39 }
  40
  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
  45
  46   (* Do the menus. *)
  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
  51
  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
  57
  58   (* Quit. *)
  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 ()); ()));
  64
  65   (* Top status area. *)
  66   let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in
  67   hbox#pack (mklabel "Guest: ");
  68
  69   (* List of VMs. *)
  70   let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in
  71   let set_vmlist names =
  72     let combo, (model, column) = vmcombo in
  73     model#clear ();
  74     List.iter (
  75       fun name ->
  76         let row = model#append () in
  77         model#set ~row ~column name
  78     ) names
  79   in
  80   let clear_vmlist () = set_vmlist [] in
  81
  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*)
  85   let throbber =
  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
  94   in
  95
  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 () =
 104     nb#goto_page 0;
 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
 109   in
 110
 111   (* Status bar at the bottom of the screen. *)
 112   let set_statusbar =
 113     let statusbar = GMisc.statusbar ~packing:vbox#pack () in
 114     let context = statusbar#new_context ~name:"Standard" in
 115     ignore (context#push title);
 116     fun msg ->
 117       context#pop ();
 118       ignore (context#push msg)
 119   in
 120   let clear_statusbar () = set_statusbar "" in
 121
 122   window#show ();
 123   window#add_accel_group accel_group;
 124
 125   (* display_state which is threaded through all the other callbacks,
 126    * allowing callbacks to update the window.
 127    *)
 128   let ds = {
 129     window = 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;
 135   } in
 136
 137   (* Set up some callbacks which require access to the display_state. *)
 138   ignore (
 139     let combo, (model, column) = vmcombo in
 140     combo#connect#changed
 141       ~callback:(
 142         fun () ->
 143           match combo#active_iter with
 144           | None -> ()
 145           | Some row ->
 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))
 150   );
 151
 152   ignore (connect_item#connect#activate ~callback:(connect_dialog ds));
 153   ignore (open_item#connect#activate ~callback:(open_dialog ds));
 154
 155   (* Return the display state. *)
 156   ds
 157
 158 (* Convenience function to make a label containing some text.  It is
 159  * returned as a generic widget.
 160  *)
 161 and mklabel text =
 162   (GMisc.label ~text () :> GObj.widget)
 163
 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.
 168  *)
 169 and failure ds exn =
 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
 177
 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 ()));
 181   let msg =
 182     match uri with
 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)
 187
 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);
 193   ds.set_vmlist doms
 194
 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 ()));
 198   opened ds rw
 199
 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 ()));
 203   opened ds rw
 204
 205 and opened ds rw =
 206   ds.clear_statusbar ();
 207   ds.clear_notebook ();
 208
 209   (* Get the list of mountable filesystems. *)
 210   Slave.get_volumes (got_volume ds rw)
 211
 212 (* This callback is called once for each mountable filesystem that is
 213  * found in a guest.
 214  *)
 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;
 219
 220   (* What's on the tab. *)
 221   let tab =
 222     match vol.Slave.vol_label with
 223     | "" -> sprintf "%s" dev
 224     | label -> sprintf "%s (%s)" dev label in
 225
 226   (* What's on the notebook page. *)
 227   let page =
 228     let vbox = GPack.vbox () in
 229
 230     (* VFS stats table. *)
 231
 232     (* For calculations, see libguestfs/tools/virt-df. *)
 233     let st = vol.Slave.vol_statvfs in
 234     let factor = st.G.bsize /^ 1024L in
 235
 236     (* Right-aligned label with width, for stats table. *)
 237     let mklabelh text =
 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)
 242     and mklabelr text =
 243       let label = GMisc.label ~text ~selectable:true ~xalign:1. () in
 244       label#set_width_chars 12;
 245       (label :> GObj.widget)
 246     in
 247
 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)));
 276
 277     (* Info table. *)
 278
 279     (* Left- and right-aligned labels, for info table. *)
 280     let mklabelr text =
 281       let label = GMisc.label ~text ~xalign:1. () in
 282       label#set_width_chars 9;
 283       (label :> GObj.widget)
 284     and mklabell text =
 285       let label = GMisc.label ~text ~selectable:true ~xalign:0. () in
 286       (label :> GObj.widget)
 287     in
 288
 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);
 300
 301     (* Files display. *)
 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);
 307
 308     vbox in
 309   ignore (
 310     ds.notebook#append_page ~tab_label:(mklabel tab) (page :> GObj.widget)
 311   )
 312
 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"
 318
 319 (* Open the disk images dialog. *)
 320 and open_dialog ds () =
 321   debug "open menu";
 322   (*ds.clear_notebook ();*)
 323   failwith "XXX OPEN DLG NOT IMPL"
 324
 325 (* The introductory text which appears in the tabbed notebook to
 326  * tell the user how to start.  XXX We should add images.
 327  *)
 328 and intro_label () =
 329   let text =
 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;
 334   label
 335
 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)