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 ExtList
  20 open ExtString
  21 open Printf
  22
  23 open Utils
  24
  25 module G = Guestfs
  26
  27 let unique = let i = ref 0 in fun () -> incr i; !i
  28
  29 (* The type of the hidden column used to implement on-demand loading.
  30  * We are going to store these in the model as simple ints because that
  31  * is easier on the GC.  Don't change these numbers!
  32  *)
  33 let isFile = 0           (* it's not a directory, there are no children *)
  34 let dirNotStarted = 1    (* user has not tried to open this *)
  35 let dirLoading = 2       (* user tried to open it, still loading *)
  36 let isDir = 3            (* we've loaded the children of this directory *)
  37 let loading = 4          (* this row contains the "Loading ..." message *)
  38
  39 let rec filetree dev rw =
  40   let view = GTree.view () in
  41   (*view#set_rules_hint true;*)
  42   view#selection#set_mode `MULTIPLE;
  43
  44   (* Hash of index numbers -> other data.  We do this because it's
  45    * more efficient for the GC compared to storing OCaml objects
  46    * directly in the rows.
  47    *)
  48   let hash = Hashtbl.create 1023 in
  49
  50   (* The columns stored in each row.  The hidden [state_col] column
  51    * stores the current state of the row, and is used to implement
  52    * on-demand loading.  The hidden [index_col] column is an index into
  53    * the hash table that records everything else about this row
  54    * (filename, file stat, etc).  The other display columns, eg.
  55    * [name_col] contain Pango markup and thus have to be escaped.
  56    *)
  57   let cols = new GTree.column_list in
  58   (* Hidden: *)
  59   let state_col = cols#add Gobject.Data.int in
  60   let index_col = cols#add Gobject.Data.int in
  61   (* Displayed: *)
  62   let mode_col = cols#add Gobject.Data.string in
  63   let name_col = cols#add Gobject.Data.string in
  64   let size_col = cols#add Gobject.Data.int64 in
  65   let date_col = cols#add Gobject.Data.string in
  66   let link_col = cols#add Gobject.Data.string in
  67
  68   let model = GTree.tree_store cols in
  69   view#set_model (Some (model :> GTree.model));
  70
  71   let renderer = GTree.cell_renderer_text [], ["markup", mode_col] in
  72   let mode_view = GTree.view_column ~title:"Permissions" ~renderer () in
  73   ignore (view#append_column mode_view);
  74
  75   let renderer = GTree.cell_renderer_text [], ["markup", name_col] in
  76   let name_view = GTree.view_column ~title:"Filename" ~renderer () in
  77   ignore (view#append_column name_view);
  78
  79   let renderer = GTree.cell_renderer_text [], ["text", size_col] in
  80   let size_view = GTree.view_column ~title:"Size" ~renderer () in
  81   ignore (view#append_column size_view);
  82
  83   let renderer = GTree.cell_renderer_text [], ["markup", date_col] in
  84   let date_view = GTree.view_column ~title:"Date" ~renderer () in
  85   ignore (view#append_column date_view);
  86
  87   let renderer = GTree.cell_renderer_text [], ["markup", link_col] in
  88   let link_view = GTree.view_column ~title:"Link" ~renderer () in
  89   ignore (view#append_column link_view);
  90
  91   let tree =
  92     model, view, hash, dev, rw,
  93     (state_col, index_col, mode_col, name_col, size_col, date_col,
  94      link_col) in
  95
  96   (* Create the root directory entry, then expand it which will force
  97    * it to be loaded (asynchronously).
  98    * XXX Should stat "/"
  99    *)
 100   let root = model#append () in
 101   add_directory_row tree root "/" None;
 102   view#expand_row (model#get_path root);
 103
 104   ignore (view#event#connect#button_press ~callback:(button_press tree));
 105   (*ignore (view#event#connect#popup_menu ~callback);*)
 106
 107   view
 108
 109 (* Add an "embryonic" directory to the tree store.  This contains a
 110  * dummy entry (as explained
 111  * http://mail.gnome.org/archives/gtk-app-devel-list/2003-May/msg00241.html)
 112  * and when the user opens it, it triggers the real directory to be
 113  * read.
 114  *)
 115 and add_directory_row tree row filename direntry =
 116   let model, view, hash, _, _,
 117     (state_col, index_col, mode_col, name_col, size_col, date_col,
 118      link_col)
 119     = tree in
 120
 121   model#set ~row ~column:state_col dirNotStarted;
 122   model#set ~row ~column:index_col (-1);
 123   model#set ~row ~column:name_col (markup_of_name filename);
 124   (match direntry with
 125    | None -> ()
 126    | Some direntry ->
 127        let index = unique () in
 128        Hashtbl.add hash index direntry;
 129        model#set ~row ~column:index_col index;
 130        let stat = direntry.Slave.dent_stat in
 131        model#set ~row ~column:mode_col (markup_of_mode stat.G.mode);
 132        model#set ~row ~column:size_col stat.G.size;
 133        model#set ~row ~column:date_col (markup_of_date stat.G.mtime));
 134
 135   let placeholder = model#append ~parent:row () in
 136   model#set ~row:placeholder ~column:state_col loading;
 137   model#set ~row:placeholder ~column:index_col (-1);
 138   model#set ~row:placeholder ~column:name_col "<i>Loading ...</i>";
 139   ignore (view#connect#row_expanded ~callback:(expand_row tree))
 140
 141 (* This is called when the user expands the [directory] row. *)
 142 and expand_row tree row _ =
 143   let model, _, _, dev, _, (state_col, _, _, _, _, _, _) = tree in
 144
 145   match model#get ~row ~column:state_col with
 146   | 1 (* dirNotStarted *) -> (* Kick off a directory read. *)
 147       (* Get a stable path for this row so we can use it inside
 148        * the callback, which may happen a lot later.
 149        *)
 150       let path = model#get_path row in
 151
 152       (* Now invoke libguestfs in the slave thread. *)
 153       Slave.read_directory
 154         dev (get_pathname tree row) (read_directory_cb tree path);
 155
 156       (* Mark this row as now loading, so we don't start another
 157        * directory read if the user expands it again.
 158        *)
 159       model#set ~row ~column:state_col dirLoading
 160
 161   | 0 (* isFile *) | 2 (* dirLoading *) | 3 (* isDir *) -> ()
 162   | 4 (* loading *) -> assert false
 163   | _ -> assert false
 164
 165 and read_directory_cb tree path entries =
 166   let model, _, hash, _, _,
 167     (state_col, index_col, mode_col, name_col, size_col, date_col,
 168      link_col)
 169     = tree in
 170
 171   let row = model#get_iter path in
 172
 173   (* Add the entries. *)
 174   List.iter (
 175     fun direntry ->
 176       let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
 177         direntry in
 178       let row = model#append ~parent:row () in
 179       if is_directory stat.G.mode then
 180         add_directory_row tree row name (Some direntry)
 181       else (
 182         let index = unique () in
 183         Hashtbl.add hash index direntry;
 184         model#set ~row ~column:state_col isFile;
 185         model#set ~row ~column:index_col index;
 186         model#set ~row ~column:name_col (markup_of_name name);
 187         model#set ~row ~column:mode_col (markup_of_mode stat.G.mode);
 188         model#set ~row ~column:size_col stat.G.size;
 189         model#set ~row ~column:date_col (markup_of_date stat.G.mtime);
 190         model#set ~row ~column:link_col (markup_of_link link)
 191       )
 192   ) entries;
 193
 194   (* Remove the placeholder entry.  NB. Must be done AFTER adding
 195    * the other entries, or else Gtk will unexpand the row.
 196    *)
 197   (try
 198      let placeholder = model#iter_children ~nth:0 (Some row) in
 199      ignore (model#remove placeholder)
 200    with Invalid_argument _ -> ());
 201
 202   (* The original directory entry has now been loaded, so
 203    * update its state.
 204    *)
 205   model#set ~row ~column:state_col isDir
 206
 207 (* Get the actual full pathname of a row. *)
 208 and get_pathname tree row =
 209   let model, _, _, _, _, _ = tree in
 210
 211   match model#iter_parent row with
 212   | None -> "/"
 213   | Some parent ->
 214       match get_direntry_of_row tree row with
 215       | Some { Slave.dent_name = name } ->
 216           let pname = get_pathname tree parent in
 217           if pname = "/" then "/" ^ name else pname ^ "/" ^ name
 218       | None ->
 219           assert false
 220
 221 (* Get the directory entry from a row (contains the stat(2) results etc).
 222  * Some rows don't have the required information (eg. placeholder rows
 223  * and currently the root directory) and for them we return [None].
 224  *)
 225 and get_direntry_of_row tree row =
 226   let model, _, hash, _, _, (_, index_col, _, _, _, _, _) = tree in
 227   let index = model#get ~row ~column:index_col in
 228   try Some (Hashtbl.find hash index)
 229   with Not_found -> None
 230
 231 (* XXX No binding for g_markup_escape in lablgtk2. *)
 232 and markup_escape name =
 233   let f = function
 234     | '&' -> "&amp;" | '<' -> "&lt;" | '>' -> "&gt;"
 235     | c -> String.make 1 c
 236   in
 237   String.replace_chars f name
 238
 239 (* Mark up a filename for the name_col column. *)
 240 and markup_of_name name =
 241   (* First, protect against any markup in the name. *)
 242   let name = markup_escape name in
 243   name
 244
 245 (* Mark up symbolic links. *)
 246 and markup_of_link link =
 247   let link = markup_escape link in
 248   if link <> "" then utf8_rarrow ^ " " ^ link else ""
 249
 250 (* Mark up mode. *)
 251 and markup_of_mode mode =
 252   let c =
 253     if is_socket mode then 's'
 254     else if is_symlink mode then 'l'
 255     else if is_regular_file mode then '-'
 256     else if is_block mode then 'b'
 257     else if is_directory mode then 'd'
 258     else if is_char mode then 'c'
 259     else if is_fifo mode then 'p' else '?' in
 260   let ru = if test_bit 0o400L mode then 'r' else '-' in
 261   let wu = if test_bit 0o200L mode then 'w' else '-' in
 262   let xu = if test_bit 0o100L mode then 'x' else '-' in
 263   let rg = if test_bit 0o40L mode then 'r' else '-' in
 264   let wg = if test_bit 0o20L mode then 'w' else '-' in
 265   let xg = if test_bit 0o10L mode then 'x' else '-' in
 266   let ro = if test_bit 0o4L mode then 'r' else '-' in
 267   let wo = if test_bit 0o2L mode then 'w' else '-' in
 268   let xo = if test_bit 0o1L mode then 'x' else '-' in
 269   let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
 270
 271   let suid = test_bit 0o4000L mode in
 272   let sgid = test_bit 0o2000L mode in
 273   let svtx = test_bit 0o1000L mode in
 274   if suid then str.[3] <- 's';
 275   if sgid then str.[6] <- 's';
 276   if svtx then str.[9] <- 't';
 277
 278   "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
 279
 280 (* File type tests. *)
 281 and file_type mask mode = Int64.logand mode 0o170000L = mask
 282
 283 and is_socket mode =       file_type 0o140000L mode
 284 and is_symlink mode =      file_type 0o120000L mode
 285 and is_regular_file mode = file_type 0o100000L mode
 286 and is_block mode =        file_type 0o060000L mode
 287 and is_directory mode =    file_type 0o040000L mode
 288 and is_char mode =         file_type 0o020000L mode
 289 and is_fifo mode =         file_type 0o010000L mode
 290
 291 and test_bit mask mode = Int64.logand mode mask = mask
 292
 293 (* Mark up dates. *)
 294 and markup_of_date time =
 295   let time = Int64.to_float time in
 296   let tm = Unix.localtime time in
 297   sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
 298     (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
 299     tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
 300
 301 (* Handle mouse button press on the selected row.  This opens the
 302  * pop-up context menu.
 303  * http://scentric.net/tutorial/sec-selections-context-menus.html
 304  *)
 305 and button_press tree ev =
 306   let button = GdkEvent.Button.button ev in
 307   let x = int_of_float (GdkEvent.Button.x ev) in
 308   let y = int_of_float (GdkEvent.Button.y ev) in
 309   let time = GdkEvent.Button.time ev in
 310
 311   (* Right button for opening the context menu. *)
 312   if button = 3 then (
 313     let model, view, hash, _, _, (_, index_col, _, _, _, _, _) = tree in
 314
 315     (* If no row is selected, select the row under the mouse. *)
 316     let paths =
 317       let sel = view#selection in
 318       if sel#count_selected_rows < 1 then (
 319         match view#get_path_at_pos ~x ~y with
 320         | None -> []
 321         | Some (path, _, _, _) ->
 322             sel#unselect_all ();
 323             sel#select_path path;
 324             [path]
 325       ) else
 326         sel#get_selected_rows (* actually returns paths *) in
 327
 328     (* Ignore paths that don't contain index fields, and get the
 329      * direntry for the others.  Currently this causes the root
 330      * directory to be ignored because we don't have stat information
 331      * for it (XXX).
 332      *)
 333     let paths =
 334       List.filter_map (
 335         fun path ->
 336           let row = model#get_iter path in
 337           match get_direntry_of_row tree row with
 338           | None -> None
 339           | Some direntry -> Some (path, direntry)
 340       ) paths in
 341
 342     (* Choose the menu and menu options according to the number of
 343      * selected rows and what is selected.
 344      *)
 345     let menu =
 346       try
 347         (match paths with
 348          | [] -> None
 349          | [path, direntry] ->          (* Single selection. *)
 350              (* What object is selected? *)
 351              let stat = direntry.Slave.dent_stat in
 352              let mode = stat.G.mode in
 353              if is_directory mode then
 354                Some (make_context_menu tree ~dir:true ~file:false paths)
 355              else if is_regular_file mode then
 356                Some (make_context_menu tree ~dir:false ~file:true paths)
 357              else (* not directory, not regular file *)
 358                Some (make_context_menu tree ~dir:false ~file:false paths)
 359          | paths ->                        (* Multiple selection. *)
 360              let dir = List.for_all (
 361                fun (_, { Slave.dent_stat = stat }) ->
 362                  is_directory stat.G.mode
 363              ) paths in
 364              let file = List.for_all (
 365                fun (_, { Slave.dent_stat = stat }) ->
 366                  is_regular_file stat.G.mode
 367              ) paths in
 368              Some (make_context_menu tree ~dir ~file paths)
 369         )
 370       with Not_found -> None
 371     in
 372     (match menu with
 373      | None -> ()
 374      | Some menu ->
 375          menu#popup ~button ~time;
 376     );
 377
 378     (* Return true so no other handler will run. *)
 379     true
 380   ) else
 381     (* Defer to other handlers. *)
 382     false
 383
 384 (* Make a context menu for file(s) and directory(s).  ~file is true is
 385  * they are all regular files, ~dir is true if they are all
 386  * directories.  If neither is set, then it can be a single selection
 387  * of a non-file non-directory, or it can be a mixed multiple
 388  * selection.
 389  *)
 390 and make_context_menu tree ~dir ~file paths =
 391   let _, _, _, _, rw, _ = tree in
 392   let n = List.length paths in
 393
 394   debug "make_context_menu dir %b file %b n %d" dir file n;
 395
 396   let menu = GMenu.menu () in
 397   let factory = new GMenu.factory menu in
 398
 399   (* Open appears first, and unconditionally.  This is just to catch
 400    * the case where nothing below matches, and we want to display
 401    * _something_.  Open is not necessarily useful ...
 402    *)
 403   ignore (factory#add_item "Open");
 404   ignore (factory#add_separator ());
 405
 406   if dir && n = 1 then (
 407     ignore (factory#add_item "Disk usage ...");
 408     ignore (factory#add_item "Export as an archive (tar etc) ...");
 409     ignore (factory#add_item "Export checksums ...");
 410     ignore (factory#add_item "Export as a list of files ...");
 411   );
 412
 413   if file then
 414     ignore (factory#add_item "Determine file type ...");
 415
 416   if n = 1 then
 417     ignore (factory#add_item "View permissions ...");
 418
 419   (* Write operations go below the separator. *)
 420   (match rw with
 421    | Slave.RO -> ()
 422    | Slave.RW ->
 423        ignore (factory#add_separator ());
 424
 425        if dir && n = 1 then (
 426          ignore (factory#add_item "New file ...");
 427          ignore (factory#add_item "New subdirectory ...");
 428          ignore (factory#add_item "Import an archive here ...");
 429        );
 430
 431        if file then (
 432          ignore (factory#add_item "Touch file");
 433          ignore (factory#add_item "Edit file");
 434        );
 435
 436        if n = 1 then
 437          ignore (factory#add_item "Edit permissions ...");
 438
 439        ignore (factory#add_item "Delete")
 440   );
 441
 442   menu