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