filetree.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 ExtString
  20 open ExtList
  21 open Unix
  22 open Printf
  23
  24 open Utils
  25 open DeviceSet
  26
  27 open Filetree_type
  28 open Filetree_ops
  29
  30 module G = Guestfs
  31
  32 type t = Filetree_type.t
  33
  34 let rec create ~packing () =
  35   let view = GTree.view ~packing () in
  36   (*view#set_rules_hint true;*)
  37   (*view#selection#set_mode `MULTIPLE; -- add this later *)
  38
  39   (* Hash of index numbers -> hdata.  We do this because it's more
  40    * efficient for the GC compared to storing OCaml objects directly in
  41    * the rows.
  42    *)
  43   let hash = Hashtbl.create 1023 in
  44
  45   (* The columns stored in each row.  The hidden [index_col] column is
  46    * an index into the hash table that records everything else about
  47    * this row (see hdata above).  The other display columns, eg.
  48    * [name_col] contain Pango markup and thus have to be escaped.
  49    *)
  50   let cols = new GTree.column_list in
  51   (* Hidden: *)
  52   let index_col = cols#add Gobject.Data.int in
  53   (* Displayed: *)
  54   let mode_col = cols#add Gobject.Data.string in
  55   let name_col = cols#add Gobject.Data.string in
  56   let size_col = cols#add Gobject.Data.string in
  57   let date_col = cols#add Gobject.Data.string in
  58
  59   (* Create the model. *)
  60   let model = GTree.tree_store cols in
  61
  62   (* Create the view. *)
  63   view#set_model (Some (model :> GTree.model));
  64
  65   let renderer = GTree.cell_renderer_text [], ["markup", mode_col] in
  66   let mode_view = GTree.view_column ~title:"Permissions" ~renderer () in
  67   mode_view#set_resizable true;
  68   ignore (view#append_column mode_view);
  69
  70   let renderer = GTree.cell_renderer_text [], ["markup", name_col] in
  71   let name_view = GTree.view_column ~title:"Filename" ~renderer () in
  72   name_view#set_resizable true;
  73   ignore (view#append_column name_view);
  74
  75   let renderer = GTree.cell_renderer_text [`XALIGN 1.], ["markup", size_col] in
  76   let size_view = GTree.view_column ~title:"Size" ~renderer () in
  77   size_view#set_resizable true;
  78   ignore (view#append_column size_view);
  79
  80   let renderer = GTree.cell_renderer_text [`XALIGN 1.], ["markup", date_col] in
  81   let date_view = GTree.view_column ~title:"Date" ~renderer () in
  82   date_view#set_resizable true;
  83   ignore (view#append_column date_view);
  84
  85   let t = {
  86     view = view; model = model; hash = hash;
  87     index_col = index_col;
  88     mode_col = mode_col; name_col = name_col; size_col = size_col;
  89     date_col = date_col;
  90   } in
  91
  92   (* Open a context menu when a button is pressed. *)
  93   ignore (view#event#connect#button_press ~callback:(button_press t));
  94
  95   t
  96
  97 (* Handle mouse button press on the selected row.  This opens the
  98  * pop-up context menu.
  99  * http://scentric.net/tutorial/sec-selections-context-menus.html
 100  *)
 101 and button_press ({ model = model; view = view } as t) ev =
 102   let button = GdkEvent.Button.button ev in
 103   let x = int_of_float (GdkEvent.Button.x ev) in
 104   let y = int_of_float (GdkEvent.Button.y ev) in
 105   let time = GdkEvent.Button.time ev in
 106
 107   (* Right button for opening the context menu. *)
 108   if button = 3 then (
 109 (*
 110     (* If no row is selected, select the row under the mouse. *)
 111     let paths =
 112       let sel = view#selection in
 113       if sel#count_selected_rows < 1 then (
 114         match view#get_path_at_pos ~x ~y with
 115         | None -> []
 116         | Some (path, _, _, _) ->
 117             sel#unselect_all ();
 118             sel#select_path path;
 119             [path]
 120       ) else
 121         sel#get_selected_rows (* actually returns paths *) in
 122 *)
 123     (* Select the row under the mouse. *)
 124     let paths =
 125       let sel = view#selection in
 126       match view#get_path_at_pos ~x ~y with
 127       | None -> []
 128       | Some (path, _, _, _) ->
 129           sel#unselect_all ();
 130           sel#select_path path;
 131           [path] in
 132
 133     (* Get the hdata for all the paths.  Filter out rows that it doesn't
 134      * make sense to select.
 135      *)
 136     let paths =
 137       List.filter_map (
 138         fun path ->
 139           let row = model#get_iter path in
 140           let hdata = get_hdata t row in
 141           match hdata with
 142           | { content=(Loading | ErrorMessage _ | Info _) } -> None
 143           | { content=(Top _ | Directory _ | File _) } -> Some (path, hdata)
 144       ) paths in
 145
 146     (* Based on number of selected rows and what is selected, construct
 147      * the context menu.
 148      *)
 149     if paths <> [] then (
 150       let menu = make_context_menu t paths in
 151       menu#popup ~button ~time
 152     );
 153
 154     (* Return true so no other handler will run. *)
 155     true
 156   )
 157   (* We didn't handle this, defer to other handlers. *)
 158   else false
 159
 160 and make_context_menu t paths =
 161   let menu = GMenu.menu () in
 162   let factory = new GMenu.factory menu in
 163
 164   let item = factory#add_item "Open" in
 165   item#misc#set_sensitive false;
 166
 167   let rec add_file_items path =
 168     let item = factory#add_item "File information" in
 169     item#misc#set_sensitive false;
 170     let item = factory#add_item "Checksum" in
 171     item#misc#set_sensitive false;
 172     ignore (factory#add_separator ());
 173     let item = factory#add_item "Download ..." in
 174     ignore (item#connect#activate ~callback:(download_file t path));
 175
 176   and add_directory_items path =
 177     let item = factory#add_item "Directory information" in
 178     item#misc#set_sensitive false;
 179     let item = factory#add_item "Calculate disk usage" in
 180     ignore (item#connect#activate ~callback:(disk_usage t path));
 181     ignore (factory#add_separator ());
 182     let item = factory#add_item "Download ..." in
 183     item#misc#set_sensitive false;
 184     let item = factory#add_item "Download as .tar ..." in
 185     ignore (item#connect#activate
 186               ~callback:(download_dir_tarball t Slave.Tar path));
 187     let item = factory#add_item "Download as .tar.gz ..." in
 188     ignore (item#connect#activate
 189               ~callback:(download_dir_tarball t Slave.TGZ path));
 190     let item = factory#add_item "Download as .tar.xz ..." in
 191     ignore (item#connect#activate
 192               ~callback:(download_dir_tarball t Slave.TXZ path));
 193     let item = factory#add_item "Download list of filenames ..." in
 194     ignore (item#connect#activate ~callback:(download_dir_find0 t path));
 195
 196   and add_os_items path =
 197     let item = factory#add_item "Operating system information" in
 198     ignore (item#connect#activate ~callback:(display_inspection_data t path));
 199     ignore (factory#add_separator ());
 200     add_volume_items path
 201
 202   and add_volume_items path =
 203     let item = factory#add_item "Filesystem used & free" in
 204     item#misc#set_sensitive false;
 205     let item = factory#add_item "Block device information" in
 206     item#misc#set_sensitive false;
 207     ignore (factory#add_separator ());
 208     add_directory_items path
 209   in
 210
 211   (match paths with
 212    (* single selection *)
 213    | [path, { content=Top (Slave.OS os)} ] ->  (* top level operating system *)
 214        add_os_items path
 215
 216    | [path, { content=Top (Slave.Volume dev) }] -> (* top level volume *)
 217        add_volume_items path
 218
 219    | [path, { content=Directory direntry }] ->     (* directory *)
 220        add_directory_items path
 221
 222    | [path, { content=File direntry }] ->          (* file *)
 223        add_file_items path
 224
 225    | [_, { content=Loading }]
 226    | [_, { content=ErrorMessage _ }] -> ()
 227
 228    | _ ->
 229        (* At the moment multiple selection is disabled.  When/if we
 230         * enable it we should do something intelligent here. XXX
 231         *)
 232        ()
 233   );
 234
 235   menu
 236
 237 (* Mark up mode. *)
 238 let markup_of_mode mode =
 239   let c =
 240     if is_socket mode then 's'
 241     else if is_symlink mode then 'l'
 242     else if is_regular_file mode then '-'
 243     else if is_block mode then 'b'
 244     else if is_directory mode then 'd'
 245     else if is_char mode then 'c'
 246     else if is_fifo mode then 'p' else '?' in
 247   let ru = if is_ru mode then 'r' else '-' in
 248   let wu = if is_wu mode then 'w' else '-' in
 249   let xu = if is_xu mode then 'x' else '-' in
 250   let rg = if is_rg mode then 'r' else '-' in
 251   let wg = if is_wg mode then 'w' else '-' in
 252   let xg = if is_xg mode then 'x' else '-' in
 253   let ro = if is_ro mode then 'r' else '-' in
 254   let wo = if is_wo mode then 'w' else '-' in
 255   let xo = if is_xo mode then 'x' else '-' in
 256   let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
 257
 258   let suid = is_suid mode in
 259   let sgid = is_sgid mode in
 260   let svtx = is_svtx mode in
 261   if suid then str.[3] <- 's';
 262   if sgid then str.[6] <- 's';
 263   if svtx then str.[9] <- 't';
 264
 265   "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
 266
 267 (* Mark up dates. *)
 268 let markup_of_date t =
 269   (* Guestfs gives us int64's, we want float which is OCaml's
 270    * equivalent of time_t.
 271    *)
 272   let t = Int64.to_float t in
 273
 274   let show_full_date () =
 275     let tm = localtime t in
 276     sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
 277       (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
 278       tm.tm_hour tm.tm_min tm.tm_sec
 279   in
 280
 281   (* How long ago? *)
 282   let now = time () in
 283   let ago = now -. t in
 284   if ago < 0. then (* future *)
 285     show_full_date ()
 286   else if ago < 60. then
 287     "<small>now</small>"
 288   else if ago < 60. *. 60. then
 289     sprintf "<small>%.0f minutes ago</small>" (ago /. 60.)
 290   else if ago < 60. *. 60. *. 24. then
 291     sprintf "<small>%.0f hours ago</small>" (ago /. 60. /. 60.)
 292   else if ago < 60. *. 60. *. 24. *. 28. then
 293     sprintf "<small>%.0f days ago</small>" (ago /. 60. /. 60. /. 24.)
 294   else
 295     show_full_date ()
 296
 297 (* Mark up file sizes. *)
 298 let markup_of_size bytes =
 299   sprintf "<small>%s</small>" (human_size bytes)
 300
 301 let clear { model = model; hash = hash } =
 302   model#clear ();
 303   Hashtbl.clear hash
 304
 305 let rec add ({ model = model; hash = hash } as t) name data =
 306   clear t;
 307
 308   (* Populate the top level of the filetree.  If there are operating
 309    * systems from inspection, these have their own top level entries
 310    * followed by only unreferenced filesystems.  If we didn't get
 311    * anything from inspection, then at the top level we just show
 312    * filesystems.
 313    *)
 314   let other_filesystems =
 315     DeviceSet.of_list (List.map fst data.Slave.insp_all_filesystems) in
 316   let other_filesystems =
 317     List.fold_left (fun set { Slave.insp_filesystems = fses } ->
 318                       DeviceSet.subtract set (DeviceSet.of_array fses))
 319       other_filesystems data.Slave.insp_oses in
 320
 321   (* Add top level operating systems. *)
 322   List.iter (add_top_level_os t name) data.Slave.insp_oses;
 323
 324   (* Add top level left-over filesystems. *)
 325   DeviceSet.iter (add_top_level_vol t name) other_filesystems;
 326
 327   (* Expand the first top level node. *)
 328   match model#get_iter_first with
 329   | None -> ()
 330   | Some row ->
 331       t.view#expand_row (model#get_path row)
 332
 333 and add_top_level_os ({ model = model; hash = hash } as t) name os =
 334   let markup =
 335     sprintf "<b>%s</b>\n<small>%s</small>\n<small>%s</small>"
 336       (markup_escape name) (markup_escape os.Slave.insp_hostname)
 337       (markup_escape os.Slave.insp_product_name) in
 338
 339   let row = model#append () in
 340   make_node t row (Top (Slave.OS os));
 341   model#set ~row ~column:t.name_col markup
 342
 343 and add_top_level_vol ({ model = model; hash = hash } as t) name dev =
 344   let markup =
 345     sprintf "<b>%s</b>\n<small>from %s</small>"
 346       (markup_escape dev) (markup_escape name) in
 347
 348   let row = model#append () in
 349   make_node t row (Top (Slave.Volume dev));
 350   model#set ~row ~column:t.name_col markup
 351
 352 (* Generic function to make an openable node to the tree. *)
 353 and make_node ({ model = model; hash = hash } as t) row content =
 354   let hdata = { state=NodeNotStarted; content=content; visited=false } in
 355   store_hdata t row hdata;
 356
 357   (* Create a placeholder "loading ..." row underneath this node so
 358    * the user has something to expand.
 359    *)
 360   let placeholder = model#append ~parent:row () in
 361   let hdata = { state=IsLeaf; content=Loading; visited=false } in
 362   store_hdata t placeholder hdata;
 363   model#set ~row:placeholder ~column:t.name_col "<i>Loading ...</i>";
 364   ignore (t.view#connect#row_expanded ~callback:(expand_row t))
 365
 366 and make_leaf ({ model = model; hash = hash } as t) row content =
 367   let hdata = { state=IsLeaf; content=content; visited=false } in
 368   store_hdata t row hdata
 369
 370 (* This is called when the user expands a row. *)
 371 and expand_row ({ model = model; hash = hash } as t) row _ =
 372   match get_hdata t row with
 373   | { state=NodeNotStarted; content=Top src } as hdata ->
 374       (* User has opened a top level node that was not previously opened. *)
 375
 376       (* Mark this row as loading, so we don't try to open it again. *)
 377       hdata.state <- NodeLoading;
 378
 379       (* Get a stable path for this row. *)
 380       let path = model#get_path row in
 381
 382       Slave.read_directory ~fail:(when_read_directory_fail t path)
 383         src "/" (when_read_directory t path)
 384
 385   | { state=NodeNotStarted; content=Directory direntry } as hdata ->
 386       (* User has opened a filesystem directory not previously opened. *)
 387
 388       (* Mark this row as loading. *)
 389       hdata.state <- NodeLoading;
 390
 391       (* Get a stable path for this row. *)
 392       let path = model#get_path row in
 393
 394       let src, pathname = get_pathname t row in
 395
 396       Slave.read_directory ~fail:(when_read_directory_fail t path)
 397         src pathname (when_read_directory t path)
 398
 399   | { state=(NodeLoading|IsNode) } -> ()
 400
 401   (* These are not nodes so it should never be possible to open them. *)
 402   | { content=File _ } | { state=IsLeaf } -> assert false
 403
 404   (* Node should not exist in the tree. *)
 405   | { state=NodeNotStarted; content=(Loading | ErrorMessage _ | Info _) } ->
 406       assert false
 407
 408 (* This is the callback when the slave has read the directory for us. *)
 409 and when_read_directory ({ model = model } as t) path entries =
 410   debug "when_read_directory";
 411
 412   let row = model#get_iter path in
 413
 414   (* Add the entries. *)
 415   List.iter (
 416     fun direntry ->
 417       let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
 418         direntry in
 419       let row = model#append ~parent:row () in
 420       if is_directory stat.G.mode then
 421         make_node t row (Directory direntry)
 422       else
 423         make_leaf t row (File direntry);
 424       model#set ~row ~column:t.name_col (markup_of_name direntry);
 425       model#set ~row ~column:t.mode_col (markup_of_mode stat.G.mode);
 426       model#set ~row ~column:t.size_col (markup_of_size stat.G.size);
 427       model#set ~row ~column:t.date_col (markup_of_date stat.G.mtime);
 428   ) entries;
 429
 430   (* Remove the placeholder "Loading" entry.  NB. Must be done AFTER
 431    * adding the other entries, or else Gtk will unexpand the row.
 432    *)
 433   (try
 434      let row = find_child_node_by_content t row Loading in
 435      ignore (model#remove row)
 436    with Invalid_argument _ | Not_found -> ()
 437   );
 438
 439   (* The original directory entry has now been loaded, so
 440    * update its state.
 441    *)
 442   let hdata = get_hdata t row in
 443   hdata.state <- IsNode;
 444   set_visited t row
 445
 446 (* This is called instead of when_read_directory when the read directory
 447  * (or mount etc) failed.  Convert the "Loading" entry into the
 448  * error message.
 449  *)
 450 and when_read_directory_fail ({ model = model } as t) path exn =
 451   debug "when_read_directory_fail: %s" (Printexc.to_string exn);
 452
 453   match exn with
 454   | G.Error msg ->
 455       let row = model#get_iter path in
 456       let row = model#iter_children ~nth:0 (Some row) in
 457
 458       let hdata = { state=IsLeaf; content=ErrorMessage msg; visited=false } in
 459       store_hdata t row hdata;
 460
 461       model#set ~row ~column:t.name_col (markup_escape msg)
 462
 463   | exn ->
 464       (* unexpected exception: re-raise it *)
 465       raise exn