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:700 ~height:700 ~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_kvm_item = factory#add_item "_Connect to local KVM hypervisor" in
  54   let connect_xen_item = factory#add_item "_Connect to local Xen hypervisor" in
  55   let connect_none_item = factory#add_item "_Connect to default hypervisor" in
  56   let connect_uri_item = factory#add_item "_Connect to a libvirt URI ..." in
  57   ignore (factory#add_separator ());
  58   let open_image_item =
  59     factory#add_item "_Open disk image ..." ~key:GdkKeysyms._O in
  60   ignore (factory#add_separator ());
  61   let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
  62
  63   (* Quit. *)
  64   let quit _ = GMain.quit (); false in
  65   ignore (window#connect#destroy ~callback:GMain.quit);
  66   ignore (window#event#connect#delete ~callback:quit);
  67   ignore (quit_item#connect#activate
  68             ~callback:(fun () -> ignore (quit ()); ()));
  69
  70   (* Top status area. *)
  71   let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in
  72   hbox#pack (mklabel "Guest: ");
  73
  74   (* List of VMs. *)
  75   let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in
  76   let set_vmlist names =
  77     let combo, (model, column) = vmcombo in
  78     model#clear ();
  79     List.iter (
  80       fun name ->
  81         let row = model#append () in
  82         model#set ~row ~column name
  83     ) names
  84   in
  85   let clear_vmlist () = set_vmlist [] in
  86
  87   (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *)
  88   let static = Throbber.static () in
  89   (*let animation = Throbber.animation () in*)
  90   let throbber =
  91     GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in
  92   let throbber_busy () =
  93     (*throbber#set_pixbuf animation*)
  94     (* Workaround because no binding for GdkPixbufAnimation: *)
  95     let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in
  96     throbber#set_file file
  97   and throbber_idle () =
  98     throbber#set_pixbuf static
  99   in
 100
 101   (* Tabbed pane ("notebook") filling the main window. *)
 102   let nb = GPack.notebook ~scrollable:true
 103     ~packing:(vbox#pack ~expand:true ~fill:true) () in
 104   let filesystem = GPack.vbox () in
 105   filesystem#add (intro_label () :> GObj.widget);
 106   ignore (nb#append_page
 107             ~tab_label:(mklabel "Filesystem") (filesystem :> GObj.widget));
 108   let clear_notebook () =
 109     nb#goto_page 0;
 110     (* Remove all tabs except the first ("Filesystem") tab ... *)
 111     List.iter nb#remove (List.tl nb#all_children);
 112     (* ... and clear out the filesystem tab. *)
 113     List.iter filesystem#remove filesystem#all_children
 114   in
 115
 116   (* Status bar at the bottom of the screen. *)
 117   let set_statusbar =
 118     let statusbar = GMisc.statusbar ~packing:vbox#pack () in
 119     let context = statusbar#new_context ~name:"Standard" in
 120     ignore (context#push title);
 121     fun msg ->
 122       context#pop ();
 123       ignore (context#push msg)
 124   in
 125   let clear_statusbar () = set_statusbar "" in
 126
 127   window#show ();
 128   window#add_accel_group accel_group;
 129
 130   (* display_state which is threaded through all the other callbacks,
 131    * allowing callbacks to update the window.
 132    *)
 133   let ds = {
 134     window = window;
 135     throbber_busy = throbber_busy; throbber_idle = throbber_idle;
 136     set_statusbar = set_statusbar; clear_statusbar = clear_statusbar;
 137     set_vmlist = set_vmlist; clear_vmlist = clear_vmlist;
 138     clear_notebook = clear_notebook;
 139     filesystem = filesystem; notebook = nb;
 140   } in
 141
 142   (* Set up some callbacks which require access to the display_state. *)
 143   ignore (
 144     let combo, (model, column) = vmcombo in
 145     combo#connect#changed
 146       ~callback:(
 147         fun () ->
 148           Option.may (fun row -> open_domain ds (model#get ~row ~column))
 149             combo#active_iter
 150       )
 151   );
 152
 153   ignore (connect_kvm_item#connect#activate
 154             ~callback:(fun () -> connect ds (Some "qemu:///system")));
 155   ignore (connect_xen_item#connect#activate
 156             ~callback:(fun () -> connect ds (Some "xen:///")));
 157   ignore (connect_none_item#connect#activate
 158             ~callback:(fun () -> connect ds None));
 159   ignore (connect_uri_item#connect#activate ~callback:(connect_uri_dialog ds));
 160   ignore (open_image_item#connect#activate ~callback:(open_image_dialog ds));
 161
 162   (* Return the display state. *)
 163   ds
 164
 165 (* Convenience function to make a label containing some text.  It is
 166  * returned as a generic widget.
 167  *)
 168 and mklabel text =
 169   (GMisc.label ~text () :> GObj.widget)
 170
 171 (* This is called in the main thread whenever a command fails in the
 172  * slave thread.  The command queue has been cleared before this is
 173  * called, so our job here is to reset the main window, and if
 174  * necessary to turn the exception into an error message.
 175  *)
 176 and failure ds exn =
 177   let title = "Error" in
 178   let msg = Printexc.to_string exn in
 179   debug "thread id %d: failure hook: %s" (Thread.id (Thread.self ())) msg;
 180   let icon = GMisc.image () in
 181   icon#set_stock `DIALOG_ERROR;
 182   icon#set_icon_size `DIALOG;
 183   GToolbox.message_box ~title ~icon msg
 184
 185 (* Perform action to open the named libvirt URI. *)
 186 and connect ds uri =
 187   (match uri with
 188    | None -> ds.set_statusbar "Connecting to default libvirt ...";
 189    | Some uri -> ds.set_statusbar (sprintf "Connecting to %s ..." uri));
 190   ds.clear_notebook ();
 191   Slave.discard_command_queue ();
 192   Slave.connect uri (connected ds uri)
 193
 194 (* This is called in the main thread when we've connected to libvirt. *)
 195 and connected ds uri () =
 196   debug "thread id %d: connected callback" (Thread.id (Thread.self ()));
 197   let msg =
 198     match uri with
 199     | None -> "Connected to libvirt"
 200     | Some uri -> sprintf "Connected to %s" uri in
 201   ds.set_statusbar msg;
 202   Slave.get_domains (got_domains ds)
 203
 204 (* This is called in the main thread when we've got the list of domains. *)
 205 and got_domains ds doms =
 206   let doms = List.map (fun { Slave.dom_name = name } -> name) doms in
 207   debug "thread id %d: got_domains callback: (%s)"
 208     (Thread.id (Thread.self ())) (String.concat " " doms);
 209   ds.set_vmlist doms
 210
 211 (* Perform action to open the named domain. *)
 212 and open_domain ds name =
 213   ds.set_statusbar (sprintf "Opening %s ..." name);
 214   ds.clear_notebook ();
 215   Slave.discard_command_queue ();
 216   Slave.open_domain name (opened_domain ds)
 217
 218 (* This callback indicates that the domain was opened successfully. *)
 219 and opened_domain ds rw =
 220   debug "thread id %d: opened_domain callback" (Thread.id (Thread.self ()));
 221   _opened ds rw
 222
 223 (* Perform action of opening disk image(s). *)
 224 and open_images ds images =
 225   ds.set_statusbar (sprintf "Opening disk image %s ..."
 226                       (String.concat " " images));
 227   ds.clear_notebook ();
 228   Slave.discard_command_queue ();
 229   Slave.open_images images (opened_images ds)
 230
 231 (* This callback indicates that local disk image(s) were opened successfully.*)
 232 and opened_images ds rw =
 233   debug "thread id %d: opened_images callback" (Thread.id (Thread.self ()));
 234   _opened ds rw
 235
 236 and _opened ds rw =
 237   ds.set_statusbar ("Opening filesystems ...");
 238   ds.clear_notebook ();
 239
 240   (* Get the list of mountable filesystems. *)
 241   Slave.get_volumes (got_volume ds rw)
 242
 243 (* This callback is called once for each mountable filesystem that is
 244  * found in a guest.
 245  *)
 246 and got_volume ds rw vol =
 247   ds.clear_statusbar ();
 248
 249   let dev = vol.Slave.vol_device in
 250   debug "thread id %d: got_volume callback: %s"
 251     (Thread.id (Thread.self ())) dev;
 252
 253   (* What's on the tab. *)
 254   let tab =
 255     match vol.Slave.vol_label with
 256     | "" -> sprintf "%s" dev
 257     | label -> sprintf "%s (%s)" dev label in
 258
 259   (* What's on the notebook page. *)
 260   let page =
 261     let vbox = GPack.vbox () in
 262
 263     (* VFS stats table. *)
 264
 265     (* For calculations, see libguestfs/tools/virt-df. *)
 266     let st = vol.Slave.vol_statvfs in
 267     let factor = st.G.bsize /^ 1024L in
 268
 269     (* Right-aligned label with width, for stats table. *)
 270     let mklabelh text =
 271       let markup = "<b>" ^ text ^ "</b>" in
 272       let label = GMisc.label ~markup ~xalign:1. () in
 273       label#set_width_chars 12;
 274       (label :> GObj.widget)
 275     and mklabelr text =
 276       let label = GMisc.label ~text ~selectable:true ~xalign:1. () in
 277       label#set_width_chars 12;
 278       (label :> GObj.widget)
 279     in
 280
 281     let stats = GPack.table ~columns:4 ~rows:5
 282       ~homogeneous:true ~col_spacings:4 ~row_spacings:4
 283       ~packing:vbox#pack () in
 284     stats#attach ~top:0 ~left:0 (mklabelh "1K-blocks");
 285     stats#attach ~top:0 ~left:1 (mklabelh "Used");
 286     stats#attach ~top:0 ~left:2 (mklabelh "Available");
 287     stats#attach ~top:0 ~left:3 (mklabelh "Use%");
 288     let blocks = st.G.blocks *^ factor in
 289     stats#attach ~top:1 ~left:0 (mklabelr (sprintf "%Ld" blocks));
 290     let used = (st.G.blocks -^ st.G.bfree) *^ factor in
 291     stats#attach ~top:1 ~left:1 (mklabelr (sprintf "%Ld" used));
 292     let available = st.G.bavail *^ factor in
 293     stats#attach ~top:1 ~left:2 (mklabelr (sprintf "%Ld" available));
 294     stats#attach ~top:1 ~left:3
 295       (mklabelr (sprintf "%Ld%%" (100L -^ 100L *^ st.G.bfree /^ st.G.blocks)));
 296     stats#attach ~top:2 ~left:0 (mklabelr ("= " ^ human_size_1k blocks));
 297     stats#attach ~top:2 ~left:1 (mklabelr ("= " ^ human_size_1k used));
 298     stats#attach ~top:2 ~left:2 (mklabelr ("= " ^ human_size_1k available));
 299     stats#attach ~top:3 ~left:0 (mklabelh "Inodes");
 300     stats#attach ~top:3 ~left:1 (mklabelh "IUsed");
 301     stats#attach ~top:3 ~left:2 (mklabelh "IFree");
 302     stats#attach ~top:3 ~left:3 (mklabelh "IUse%");
 303     stats#attach ~top:4 ~left:0 (mklabelr (sprintf "%Ld" st.G.files));
 304     stats#attach ~top:4 ~left:1
 305       (mklabelr (sprintf "%Ld" (st.G.files -^ st.G.ffree)));
 306     stats#attach ~top:4 ~left:2 (mklabelr (sprintf "%Ld" st.G.ffree));
 307     stats#attach ~top:4 ~left:3
 308       (mklabelr (sprintf "%Ld%%" (100L -^ 100L *^ st.G.ffree /^ st.G.files)));
 309
 310     (* Info table. *)
 311
 312     (* Left- and right-aligned labels, for info table. *)
 313     let mklabelr text =
 314       let label = GMisc.label ~text ~xalign:1. () in
 315       label#set_width_chars 9;
 316       (label :> GObj.widget)
 317     and mklabell text =
 318       let label = GMisc.label ~text ~selectable:true ~xalign:0. () in
 319       (label :> GObj.widget)
 320     in
 321
 322     let info = GPack.table ~columns:4 ~rows:2
 323       ~col_spacings:4 ~row_spacings:4
 324       ~packing:vbox#pack () in
 325     info#attach ~top:0 ~left:0 (mklabelr "FS label:");
 326     info#attach ~top:0 ~left:1 (mklabell vol.Slave.vol_label);
 327     info#attach ~top:1 ~left:0 (mklabelr "FS type:");
 328     info#attach ~top:1 ~left:1 (mklabell vol.Slave.vol_type);
 329     info#attach ~top:0 ~left:2 (mklabelr "FS UUID:");
 330     info#attach ~top:0 ~left:3 (mklabell vol.Slave.vol_uuid);
 331     info#attach ~top:1 ~left:2 (mklabelr "Device:");
 332     info#attach ~top:1 ~left:3 (mklabell dev);
 333
 334     (* Files display. *)
 335     let sw = GBin.scrolled_window
 336       ~packing:(vbox#pack ~expand:true ~fill:true)
 337       ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
 338     let view = Filetree.filetree dev rw in
 339     sw#add (view :> GObj.widget);
 340
 341     vbox in
 342   ignore (
 343     ds.notebook#append_page ~tab_label:(mklabel tab) (page :> GObj.widget)
 344   )
 345
 346 (* Open the connect to libvirt dialog. *)
 347 and connect_uri_dialog ds () =
 348   debug "connect_uri_dialog";
 349   let title = "Choose a libvirt URI" in
 350   let ok = "Connect to libvirt" in
 351   let text = "NB: Remote storage cannot be accessed, so entering
 352 a libvirt remote URI here will probably not work." in
 353   let uri = GToolbox.input_string ~title ~ok text in
 354   match uri with
 355   | None -> debug "connect_uri_dialog cancelled"; ()
 356   | Some "" -> debug "connect to default"; connect ds None
 357   | (Some s) as uri -> debug "connect to %s" s; connect ds uri
 358
 359 (* Open the disk images dialog.
 360  * XXX This can only deal with a single disk image at the moment, but
 361  * underlying code can deal with multiple.
 362  *)
 363 and open_image_dialog ds () =
 364   let title = "Choose a disk image" in
 365   let dlg = GWindow.file_chooser_dialog ~action:`OPEN ~title ~modal:true () in
 366   dlg#add_button "Open disk image" `OPEN_IMAGE;
 367   dlg#add_button "Close" `DELETE_EVENT;
 368
 369   let callback = function
 370     | `DELETE_EVENT -> debug "DELETE_EVENT response"; dlg#destroy ()
 371     | `OPEN_IMAGE ->
 372         match dlg#filename with
 373         | None -> () (* nothing selected in dialog, keep dialog open *)
 374         | Some filename ->
 375             debug "OPEN_IMAGE response, filename = %s" filename;
 376             dlg#destroy ();
 377             open_images ds [filename]
 378   in
 379   ignore (dlg#connect#response ~callback);
 380
 381   dlg#show ()
 382
 383 (* The introductory text which appears in the tabbed notebook to
 384  * tell the user how to start.  XXX We should add images.
 385  *)
 386 and intro_label () =
 387   let text =
 388     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."
 389       utf8_rarrow utf8_rarrow in
 390   let label = GMisc.label ~text () in
 391   label#set_line_wrap true;
 392   label
 393
 394 let run_cli_request ds = function
 395   | Cmdline.Empty_window -> ()
 396   | Cmdline.Connect_to_libvirt uri -> connect ds uri
 397   | Cmdline.Open_disk_image images -> open_images ds images