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 ?status ~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     status = status
  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           | _, (Loading | ErrorMessage _) -> None
 143           | _, (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 "Space used by directory" in
 180     item#misc#set_sensitive false;
 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     item#misc#set_sensitive false;
 199     let item = factory#add_item "Block device information" in
 200     item#misc#set_sensitive false;
 201     let item = factory#add_item "Filesystem used & free" in
 202     item#misc#set_sensitive false;
 203     ignore (factory#add_separator ());
 204     add_directory_items path
 205
 206   and add_volume_items path =
 207     let item = factory#add_item "Filesystem used & free" in
 208     item#misc#set_sensitive false;
 209     let item = factory#add_item "Block device information" in
 210     item#misc#set_sensitive false;
 211     ignore (factory#add_separator ());
 212     add_directory_items path
 213   in
 214
 215   (match paths with
 216    (* single selection *)
 217    | [path, (_, Top (Slave.OS os))] ->       (* top level operating system *)
 218        add_os_items path
 219
 220    | [path, (_, Top (Slave.Volume dev))] ->  (* top level volume *)
 221        add_volume_items path
 222
 223    | [path, (_, Directory direntry)] ->      (* directory *)
 224        add_directory_items path
 225
 226    | [path, (_, File direntry)] ->           (* file *)
 227        add_file_items path
 228
 229    | [_, (_, Loading)]
 230    | [_, (_, ErrorMessage _)] -> ()
 231
 232    | _ ->
 233        (* At the moment multiple selection is disabled.  When/if we
 234         * enable it we should do something intelligent here. XXX
 235         *)
 236        ()
 237   );
 238
 239   menu
 240
 241 (* XXX No binding for g_markup_escape in lablgtk2. *)
 242 let markup_escape name =
 243   let f = function
 244     | '&' -> "&amp;" | '<' -> "&lt;" | '>' -> "&gt;"
 245     | c -> String.make 1 c
 246   in
 247   String.replace_chars f name
 248
 249 (* Mark up a filename for the name_col column. *)
 250 let rec markup_of_name name =
 251   markup_escape name
 252
 253 (* Mark up symbolic links. *)
 254 and markup_of_link link =
 255   let link = markup_escape link in
 256   if link <> "" then utf8_rarrow ^ " " ^ link else ""
 257
 258 (* Mark up mode. *)
 259 and markup_of_mode mode =
 260   let c =
 261     if is_socket mode then 's'
 262     else if is_symlink mode then 'l'
 263     else if is_regular_file mode then '-'
 264     else if is_block mode then 'b'
 265     else if is_directory mode then 'd'
 266     else if is_char mode then 'c'
 267     else if is_fifo mode then 'p' else '?' in
 268   let ru = if test_bit 0o400L mode then 'r' else '-' in
 269   let wu = if test_bit 0o200L mode then 'w' else '-' in
 270   let xu = if test_bit 0o100L mode then 'x' else '-' in
 271   let rg = if test_bit 0o40L mode then 'r' else '-' in
 272   let wg = if test_bit 0o20L mode then 'w' else '-' in
 273   let xg = if test_bit 0o10L mode then 'x' else '-' in
 274   let ro = if test_bit 0o4L mode then 'r' else '-' in
 275   let wo = if test_bit 0o2L mode then 'w' else '-' in
 276   let xo = if test_bit 0o1L mode then 'x' else '-' in
 277   let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
 278
 279   let suid = test_bit 0o4000L mode in
 280   let sgid = test_bit 0o2000L mode in
 281   let svtx = test_bit 0o1000L mode in
 282   if suid then str.[3] <- 's';
 283   if sgid then str.[6] <- 's';
 284   if svtx then str.[9] <- 't';
 285
 286   "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
 287
 288 (* File type tests. *)
 289 and file_type mask mode = Int64.logand mode 0o170000L = mask
 290
 291 and is_socket mode =       file_type 0o140000L mode
 292 and is_symlink mode =      file_type 0o120000L mode
 293 and is_regular_file mode = file_type 0o100000L mode
 294 and is_block mode =        file_type 0o060000L mode
 295 and is_directory mode =    file_type 0o040000L mode
 296 and is_char mode =         file_type 0o020000L mode
 297 and is_fifo mode =         file_type 0o010000L mode
 298
 299 and test_bit mask mode = Int64.logand mode mask = mask
 300
 301 (* Mark up dates. *)
 302 and markup_of_date time =
 303   let time = Int64.to_float time in
 304   let tm = Unix.localtime time in
 305   sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
 306     (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
 307     tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
 308
 309 let clear { model = model; hash = hash } =
 310   model#clear ();
 311   Hashtbl.clear hash
 312
 313 let rec add ({ model = model; hash = hash } as t) name data =
 314   clear t;
 315
 316   (* Populate the top level of the filetree.  If there are operating
 317    * systems from inspection, these have their own top level entries
 318    * followed by only unreferenced filesystems.  If we didn't get
 319    * anything from inspection, then at the top level we just show
 320    * filesystems.
 321    *)
 322   let other_filesystems =
 323     DeviceSet.of_list (List.map fst data.Slave.insp_all_filesystems) in
 324   let other_filesystems =
 325     List.fold_left (fun set { Slave.insp_filesystems = fses } ->
 326                       DeviceSet.subtract set (DeviceSet.of_array fses))
 327       other_filesystems data.Slave.insp_oses in
 328
 329   (* Add top level operating systems. *)
 330   List.iter (add_top_level_os t name) data.Slave.insp_oses;
 331
 332   (* Add top level left-over filesystems. *)
 333   DeviceSet.iter (add_top_level_vol t name) other_filesystems;
 334
 335   (* Expand the first top level node. *)
 336   match model#get_iter_first with
 337   | None -> ()
 338   | Some row ->
 339       t.view#expand_row (model#get_path row)
 340
 341 and add_top_level_os ({ model = model; hash = hash } as t) name os =
 342   let markup =
 343     sprintf "<b>%s</b>\n<small>%s</small>\n<small>%s</small>"
 344       (markup_escape name) (markup_escape os.Slave.insp_hostname)
 345       (markup_escape os.Slave.insp_product_name) in
 346
 347   let row = model#append () in
 348   make_node t row (Top (Slave.OS os));
 349   model#set ~row ~column:t.name_col markup
 350
 351 and add_top_level_vol ({ model = model; hash = hash } as t) name dev =
 352   let markup =
 353     sprintf "<b>%s</b>\n<small>from %s</small>"
 354       (markup_escape dev) (markup_escape name) in
 355
 356   let row = model#append () in
 357   make_node t row (Top (Slave.Volume dev));
 358   model#set ~row ~column:t.name_col markup
 359
 360 (* Generic function to make an openable node to the tree. *)
 361 and make_node ({ model = model; hash = hash } as t) row content =
 362   let hdata = NodeNotStarted, content in
 363   store_hdata t row hdata;
 364
 365   (* Create a placeholder "loading ..." row underneath this node so
 366    * the user has something to expand.
 367    *)
 368   let placeholder = model#append ~parent:row () in
 369   let hdata = IsLeaf, Loading in
 370   store_hdata t placeholder hdata;
 371   model#set ~row:placeholder ~column:t.name_col "<i>Loading ...</i>";
 372   ignore (t.view#connect#row_expanded ~callback:(expand_row t))
 373
 374 and make_leaf ({ model = model; hash = hash } as t) row content =
 375   let hdata = IsLeaf, content in
 376   store_hdata t row hdata
 377
 378 (* This is called when the user expands a row. *)
 379 and expand_row ({ model = model; hash = hash } as t) row _ =
 380   match get_hdata t row with
 381   | NodeNotStarted, Top src ->
 382       (* User has opened a top level node that was not previously opened. *)
 383
 384       (* Mark this row as loading, so we don't try to open it again. *)
 385       let hdata = NodeLoading, Top src in
 386       store_hdata t row hdata;
 387
 388       (* Get a stable path for this row. *)
 389       let path = model#get_path row in
 390
 391       Slave.read_directory ~fail:(when_read_directory_fail t path)
 392         src "/" (when_read_directory t path)
 393
 394   | NodeNotStarted, Directory direntry ->
 395       (* User has opened a filesystem directory not previously opened. *)
 396
 397       (* Mark this row as loading. *)
 398       let hdata = NodeLoading, Directory direntry in
 399       store_hdata t row hdata;
 400
 401       (* Get a stable path for this row. *)
 402       let path = model#get_path row in
 403
 404       let src, pathname = get_pathname t row in
 405
 406       Slave.read_directory ~fail:(when_read_directory_fail t path)
 407         src pathname (when_read_directory t path)
 408
 409   | NodeLoading, _ | IsNode, _ -> ()
 410
 411   (* These are not nodes so it should never be possible to open them. *)
 412   | _, File _ | IsLeaf, _ -> assert false
 413
 414   (* Node should not exist in the tree. *)
 415   | NodeNotStarted, (Loading | ErrorMessage _) -> assert false
 416
 417 (* This is the callback when the slave has read the directory for us. *)
 418 and when_read_directory ({ model = model } as t) path entries =
 419   debug "when_read_directory";
 420
 421   let row = model#get_iter path in
 422
 423   (* Add the entries. *)
 424   List.iter (
 425     fun direntry ->
 426       let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
 427         direntry in
 428       let row = model#append ~parent:row () in
 429       if is_directory stat.G.mode then
 430         make_node t row (Directory direntry)
 431       else
 432         make_leaf t row (File direntry);
 433       model#set ~row ~column:t.name_col (markup_of_name name);
 434       model#set ~row ~column:t.mode_col (markup_of_mode stat.G.mode);
 435       model#set ~row ~column:t.size_col stat.G.size;
 436       model#set ~row ~column:t.date_col (markup_of_date stat.G.mtime);
 437       model#set ~row ~column:t.link_col (markup_of_link link)
 438   ) entries;
 439
 440   (* Remove the placeholder entry.  NB. Must be done AFTER adding
 441    * the other entries, or else Gtk will unexpand the row.
 442    *)
 443   (try
 444      let placeholder = model#iter_children ~nth:0 (Some row) in
 445      ignore (model#remove placeholder)
 446    with Invalid_argument _ -> ()
 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
 476
 477 let set_status_fn t status =
 478   t.status <- Some status