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 (* The type of the hidden column used to implement on-demand loading.
  28  * We are going to store these in the model as simple ints because that
  29  * is easier on the GC.  Don't change these numbers!
  30  *)
  31 let isFile = 0           (* it's not a directory, there are no children *)
  32 let dirNotStarted = 1    (* user has not tried to open this *)
  33 let dirLoading = 2       (* user tried to open it, still loading *)
  34 let isDir = 3            (* we've loaded the children of this directory *)
  35 let loading = 4          (* this row contains the "Loading ..." message *)
  36
  37 let rec filetree dev rw =
  38   let view = GTree.view () in
  39   (*view#set_rules_hint true;*)
  40   view#selection#set_mode `MULTIPLE;
  41
  42   (* Hash of index numbers -> other data.  We do this because it's
  43    * more efficient for the GC compared to storing OCaml objects
  44    * directly in the rows.
  45    *)
  46   let hash = Hashtbl.create 1023 in
  47
  48   (* The columns stored in each row.  The hidden [state_col] column
  49    * stores the current state of the row, and is used to implement
  50    * on-demand loading.  The hidden [index_col] column is an index into
  51    * the hash table that records everything else about this row
  52    * (filename, file stat, etc).  The other display columns, eg.
  53    * [name_col] contain Pango markup and thus have to be escaped.
  54    *)
  55   let cols = new GTree.column_list in
  56   (* Hidden: *)
  57   let state_col = cols#add Gobject.Data.int in
  58   let index_col = cols#add Gobject.Data.int in
  59   (* Displayed: *)
  60   let mode_col = cols#add Gobject.Data.string in
  61   let name_col = cols#add Gobject.Data.string in
  62   let size_col = cols#add Gobject.Data.int64 in
  63   let date_col = cols#add Gobject.Data.string in
  64   let link_col = cols#add Gobject.Data.string in
  65
  66   let model = GTree.tree_store cols in
  67   view#set_model (Some (model :> GTree.model));
  68
  69   let renderer = GTree.cell_renderer_text [], ["markup", mode_col] in
  70   let mode_view = GTree.view_column ~title:"Permissions" ~renderer () in
  71   ignore (view#append_column mode_view);
  72
  73   let renderer = GTree.cell_renderer_text [], ["markup", name_col] in
  74   let name_view = GTree.view_column ~title:"Filename" ~renderer () in
  75   ignore (view#append_column name_view);
  76
  77   let renderer = GTree.cell_renderer_text [], ["text", size_col] in
  78   let size_view = GTree.view_column ~title:"Size" ~renderer () in
  79   ignore (view#append_column size_view);
  80
  81   let renderer = GTree.cell_renderer_text [], ["markup", date_col] in
  82   let date_view = GTree.view_column ~title:"Date" ~renderer () in
  83   ignore (view#append_column date_view);
  84
  85   let renderer = GTree.cell_renderer_text [], ["markup", link_col] in
  86   let link_view = GTree.view_column ~title:"Link" ~renderer () in
  87   ignore (view#append_column link_view);
  88
  89   let tree =
  90     model, view, hash, dev, rw,
  91     (state_col, index_col, mode_col, name_col, size_col, date_col,
  92      link_col) in
  93
  94   (* Create the root directory entry, then expand it which will force
  95    * it to be loaded (asynchronously).
  96    * XXX Should stat "/"
  97    *)
  98   let root = model#append () in
  99   add_directory_row tree root "/" None;
 100   view#expand_row (model#get_path root);
 101
 102   ignore (view#event#connect#button_press ~callback:(button_press tree));
 103   (*ignore (view#event#connect#popup_menu ~callback);*)
 104
 105   view
 106
 107 (* Add an "embryonic" directory to the tree store.  This contains a
 108  * dummy entry (as explained
 109  * http://mail.gnome.org/archives/gtk-app-devel-list/2003-May/msg00241.html)
 110  * and when the user opens it, it triggers the real directory to be
 111  * read.
 112  *)
 113 and add_directory_row tree row filename direntry =
 114   let model, view, hash, _, _,
 115     (state_col, index_col, mode_col, name_col, size_col, date_col,
 116      link_col)
 117     = tree in
 118
 119   model#set ~row ~column:state_col dirNotStarted;
 120   model#set ~row ~column:index_col (-1);
 121   model#set ~row ~column:name_col (markup_of_name filename);
 122   (match direntry with
 123    | None -> ()
 124    | Some direntry ->
 125        let index = unique () in
 126        Hashtbl.add hash index direntry;
 127        model#set ~row ~column:index_col index;
 128        let stat = direntry.Slave.dent_stat in
 129        model#set ~row ~column:mode_col (markup_of_mode stat.G.mode);
 130        model#set ~row ~column:size_col stat.G.size;
 131        model#set ~row ~column:date_col (markup_of_date stat.G.mtime));
 132
 133   let placeholder = model#append ~parent:row () in
 134   model#set ~row:placeholder ~column:state_col loading;
 135   model#set ~row:placeholder ~column:index_col (-1);
 136   model#set ~row:placeholder ~column:name_col "<i>Loading ...</i>";
 137   ignore (view#connect#row_expanded ~callback:(expand_row tree))
 138
 139 (* This is called when the user expands the [directory] row. *)
 140 and expand_row tree row _ =
 141   let model, _, _, dev, _, (state_col, _, _, _, _, _, _) = tree in
 142
 143   match model#get ~row ~column:state_col with
 144   | 1 (* dirNotStarted *) -> (* Kick off a directory read. *)
 145       (* Get a stable path for this row so we can use it inside
 146        * the callback, which may happen a lot later.
 147        *)
 148       let path = model#get_path row in
 149
 150       (* Now invoke libguestfs in the slave thread. *)
 151       Slave.read_directory
 152         dev (get_pathname tree row) (read_directory_cb tree path);
 153
 154       (* Mark this row as now loading, so we don't start another
 155        * directory read if the user expands it again.
 156        *)
 157       model#set ~row ~column:state_col dirLoading
 158
 159   | 0 (* isFile *) | 2 (* dirLoading *) | 3 (* isDir *) -> ()
 160   | 4 (* loading *) -> assert false
 161   | _ -> assert false
 162
 163 and read_directory_cb tree path entries =
 164   let model, _, hash, _, _,
 165     (state_col, index_col, mode_col, name_col, size_col, date_col,
 166      link_col)
 167     = tree in
 168
 169   let row = model#get_iter path in
 170
 171   (* Add the entries. *)
 172   List.iter (
 173     fun direntry ->
 174       let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
 175         direntry in
 176       let row = model#append ~parent:row () in
 177       if is_directory stat.G.mode then
 178         add_directory_row tree row name (Some direntry)
 179       else (
 180         let index = unique () in
 181         Hashtbl.add hash index direntry;
 182         model#set ~row ~column:state_col isFile;
 183         model#set ~row ~column:index_col index;
 184         model#set ~row ~column:name_col (markup_of_name name);
 185         model#set ~row ~column:mode_col (markup_of_mode stat.G.mode);
 186         model#set ~row ~column:size_col stat.G.size;
 187         model#set ~row ~column:date_col (markup_of_date stat.G.mtime);
 188         model#set ~row ~column:link_col (markup_of_link link)
 189       )
 190   ) entries;
 191
 192   (* Remove the placeholder entry.  NB. Must be done AFTER adding
 193    * the other entries, or else Gtk will unexpand the row.
 194    *)
 195   (try
 196      let placeholder = model#iter_children ~nth:0 (Some row) in
 197      ignore (model#remove placeholder)
 198    with Invalid_argument _ -> ());
 199
 200   (* The original directory entry has now been loaded, so
 201    * update its state.
 202    *)
 203   model#set ~row ~column:state_col isDir
 204
 205 (* Get the actual full pathname of a row. *)
 206 and get_pathname tree row =
 207   let model, _, _, _, _, _ = tree in
 208
 209   match model#iter_parent row with
 210   | None -> "/"
 211   | Some parent ->
 212       match get_direntry_of_row tree row with
 213       | Some { Slave.dent_name = name } ->
 214           let pname = get_pathname tree parent in
 215           if pname = "/" then "/" ^ name else pname ^ "/" ^ name
 216       | None ->
 217           assert false
 218
 219 (* Get the directory entry from a row (contains the stat(2) results etc).
 220  * Some rows don't have the required information (eg. placeholder rows
 221  * and currently the root directory) and for them we return [None].
 222  *)
 223 and get_direntry_of_row tree row =
 224   let model, _, hash, _, _, (_, index_col, _, _, _, _, _) = tree in
 225   let index = model#get ~row ~column:index_col in
 226   try Some (Hashtbl.find hash index)
 227   with Not_found -> None
 228
 229 (* XXX No binding for g_markup_escape in lablgtk2. *)
 230 and markup_escape name =
 231   let f = function
 232     | '&' -> "&amp;" | '<' -> "&lt;" | '>' -> "&gt;"
 233     | c -> String.make 1 c
 234   in
 235   String.replace_chars f name
 236
 237 (* Mark up a filename for the name_col column. *)
 238 and markup_of_name name =
 239   (* First, protect against any markup in the name. *)
 240   let name = markup_escape name in
 241   name
 242
 243 (* Mark up symbolic links. *)
 244 and markup_of_link link =
 245   let link = markup_escape link in
 246   if link <> "" then utf8_rarrow ^ " " ^ link else ""
 247
 248 (* Mark up mode. *)
 249 and markup_of_mode mode =
 250   let c =
 251     if is_socket mode then 's'
 252     else if is_symlink mode then 'l'
 253     else if is_regular_file mode then '-'
 254     else if is_block mode then 'b'
 255     else if is_directory mode then 'd'
 256     else if is_char mode then 'c'
 257     else if is_fifo mode then 'p' else '?' in
 258   let ru = if test_bit 0o400L mode then 'r' else '-' in
 259   let wu = if test_bit 0o200L mode then 'w' else '-' in
 260   let xu = if test_bit 0o100L mode then 'x' else '-' in
 261   let rg = if test_bit 0o40L mode then 'r' else '-' in
 262   let wg = if test_bit 0o20L mode then 'w' else '-' in
 263   let xg = if test_bit 0o10L mode then 'x' else '-' in
 264   let ro = if test_bit 0o4L mode then 'r' else '-' in
 265   let wo = if test_bit 0o2L mode then 'w' else '-' in
 266   let xo = if test_bit 0o1L mode then 'x' else '-' in
 267   let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
 268
 269   let suid = test_bit 0o4000L mode in
 270   let sgid = test_bit 0o2000L mode in
 271   let svtx = test_bit 0o1000L mode in
 272   if suid then str.[3] <- 's';
 273   if sgid then str.[6] <- 's';
 274   if svtx then str.[9] <- 't';
 275
 276   "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
 277
 278 (* File type tests. *)
 279 and file_type mask mode = Int64.logand mode 0o170000L = mask
 280
 281 and is_socket mode =       file_type 0o140000L mode
 282 and is_symlink mode =      file_type 0o120000L mode
 283 and is_regular_file mode = file_type 0o100000L mode
 284 and is_block mode =        file_type 0o060000L mode
 285 and is_directory mode =    file_type 0o040000L mode
 286 and is_char mode =         file_type 0o020000L mode
 287 and is_fifo mode =         file_type 0o010000L mode
 288
 289 and test_bit mask mode = Int64.logand mode mask = mask
 290
 291 (* Mark up dates. *)
 292 and markup_of_date time =
 293   let time = Int64.to_float time in
 294   let tm = Unix.localtime time in
 295   sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
 296     (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
 297     tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
 298
 299 (* Handle mouse button press on the selected row.  This opens the
 300  * pop-up context menu.
 301  * http://scentric.net/tutorial/sec-selections-context-menus.html
 302  *)
 303 and button_press tree ev =
 304   let button = GdkEvent.Button.button ev in
 305   let x = int_of_float (GdkEvent.Button.x ev) in
 306   let y = int_of_float (GdkEvent.Button.y ev) in
 307   let time = GdkEvent.Button.time ev in
 308
 309   (* Right button for opening the context menu. *)
 310   if button = 3 then (
 311     let model, view, hash, _, _, (_, index_col, _, _, _, _, _) = tree in
 312
 313     (* If no row is selected, select the row under the mouse. *)
 314     let paths =
 315       let sel = view#selection in
 316       if sel#count_selected_rows < 1 then (
 317         match view#get_path_at_pos ~x ~y with
 318         | None -> []
 319         | Some (path, _, _, _) ->
 320             sel#unselect_all ();
 321             sel#select_path path;
 322             [path]
 323       ) else
 324         sel#get_selected_rows (* actually returns paths *) in
 325
 326     (* Ignore paths that don't contain index fields, and get the
 327      * direntry for the others.  Currently this causes the root
 328      * directory to be ignored because we don't have stat information
 329      * for it (XXX).
 330      *)
 331     let paths =
 332       List.filter_map (
 333         fun path ->
 334           let row = model#get_iter path in
 335           match get_direntry_of_row tree row with
 336           | None -> None
 337           | Some direntry -> Some (path, direntry)
 338       ) paths in
 339
 340     (* Choose the menu and menu options according to the number of
 341      * selected rows and what is selected.
 342      *)
 343     let menu =
 344       try
 345         (match paths with
 346          | [] -> None
 347          | [path, direntry] ->          (* Single selection. *)
 348              (* What object is selected? *)
 349              let stat = direntry.Slave.dent_stat in
 350              let mode = stat.G.mode in
 351              if is_directory mode then
 352                Some (make_context_menu tree ~dir:true ~file:false paths)
 353              else if is_regular_file mode then
 354                Some (make_context_menu tree ~dir:false ~file:true paths)
 355              else (* not directory, not regular file *)
 356                Some (make_context_menu tree ~dir:false ~file:false paths)
 357          | paths ->                        (* Multiple selection. *)
 358              let dir = List.for_all (
 359                fun (_, { Slave.dent_stat = stat }) ->
 360                  is_directory stat.G.mode
 361              ) paths in
 362              let file = List.for_all (
 363                fun (_, { Slave.dent_stat = stat }) ->
 364                  is_regular_file stat.G.mode
 365              ) paths in
 366              Some (make_context_menu tree ~dir ~file paths)
 367         )
 368       with Not_found -> None
 369     in
 370     (match menu with
 371      | None -> ()
 372      | Some menu ->
 373          menu#popup ~button ~time;
 374     );
 375
 376     (* Return true so no other handler will run. *)
 377     true
 378   ) else
 379     (* Defer to other handlers. *)
 380     false
 381
 382 (* Make a context menu for file(s) and directory(s).  ~file is true is
 383  * they are all regular files, ~dir is true if they are all
 384  * directories.  If neither is set, then it can be a single selection
 385  * of a non-file non-directory, or it can be a mixed multiple
 386  * selection.
 387  *)
 388 and make_context_menu tree ~dir ~file paths =
 389   let _, _, _, _, rw, _ = tree in
 390   let n = List.length paths in
 391   assert (n > 0);                      (* calling code ensures this *)
 392   let path0 = List.hd paths in
 393
 394   let menu = GMenu.menu () in
 395   let factory = new GMenu.factory menu in
 396
 397   (* Open appears first, and unconditionally.  This is just to catch
 398    * the case where nothing below matches, and we want to display
 399    * _something_.  Open is not necessarily useful ...
 400    *)
 401   ignore (factory#add_item "Open");
 402   ignore (factory#add_separator ());
 403
 404   if dir && n = 1 then (
 405     let item = factory#add_item "Disk _usage ..." in
 406     ignore (item#connect#activate ~callback:(disk_usage_dialog tree path0));
 407     let item = factory#add_item "_Export as an archive (tar etc) ..." in
 408     ignore (item#connect#activate ~callback:(export_archive_dialog tree path0));
 409     let item = factory#add_item "Export _checksums ..." in
 410     ignore (item#connect#activate
 411               ~callback:(export_checksums_dialog tree path0));
 412     let item = factory#add_item "Export as a _list of files ..." in
 413     ignore (item#connect#activate ~callback:(export_list_dialog tree path0));
 414   );
 415
 416   if file then
 417     ignore (factory#add_item "Determine file type ...");
 418
 419   if n = 1 then
 420     ignore (factory#add_item "View permissions ...");
 421
 422   (* Write operations go below the separator. *)
 423   (match rw with
 424    | Slave.RO -> ()
 425    | Slave.RW ->
 426        ignore (factory#add_separator ());
 427
 428        if dir && n = 1 then (
 429          ignore (factory#add_item "New file ...");
 430          ignore (factory#add_item "New subdirectory ...");
 431          ignore (factory#add_item "Import an archive here ...");
 432        );
 433
 434        if file then (
 435          ignore (factory#add_item "Touch file");
 436          ignore (factory#add_item "Edit file");
 437        );
 438
 439        if n = 1 then
 440          ignore (factory#add_item "Edit permissions ...");
 441
 442        ignore (factory#add_item "Delete")
 443   );
 444
 445   menu
 446
 447 (* The disk usage dialog. *)
 448 and disk_usage_dialog tree path0 () =
 449   let model, _, _, dev, _,_ = tree in
 450   let row = model#get_iter (fst path0) in
 451   let dir = get_pathname tree row in
 452
 453   (* We can't use GWindow.message_dialog since lablgtk2 doesn't expose
 454    * the label field.  It wouldn't help very much anyway.
 455    *)
 456   let title = "Calculating disk usage ..." in
 457   let dlg = GWindow.dialog ~title ~modal:true () in
 458   let text =
 459     sprintf "Calculating disk usage of %s ...  This may take a moment." dir in
 460   let label = GMisc.label ~text ~packing:dlg#vbox#pack () in
 461   dlg#add_button "Stop" `STOP;
 462   dlg#add_button "Close" `DELETE_EVENT;
 463   let close_button, stop_button =
 464     match dlg#action_area#children with
 465     | c::s::_ -> c, s
 466     | _ -> assert false in
 467   close_button#misc#set_sensitive false;
 468
 469   let callback = function
 470     | `STOP -> debug "STOP response" (* XXX NOT IMPL XXX *)
 471     | `DELETE_EVENT -> debug "DELETE_EVENT response"; dlg#destroy ()
 472   in
 473   ignore (dlg#connect#response ~callback);
 474
 475   Slave.disk_usage dev dir (
 476     fun kbytes -> (* Called when operation has finished. *)
 477       dlg#set_title "Disk usage";
 478       label#set_text (sprintf "Disk usage of %s: %Ld KB" dir kbytes);
 479       close_button#misc#set_sensitive true;
 480       stop_button#misc#set_sensitive false
 481   );
 482
 483   (* NB. We cannot use dlg#run.  See:
 484    * http://www.math.nagoya-u.ac.jp/~garrigue/soft/olabl/lablgtk-list/600.txt
 485    * Therefore this function just exits back to the ordinary main loop.
 486    *)
 487   dlg#show ()
 488
 489 and export_archive_dialog tree path0 () =
 490   (* XXX NOT IMPL XXX *)
 491 (*  let model, _, _, dev, _,_ = tree in
 492   let row = model#get_iter (fst path0) in
 493   let dir = get_pathname tree row in*)
 494
 495   let title = "Choose output file" in
 496   let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
 497
 498   (* Allow the user to select the output format. *)
 499   let strings = ["tar.gz (compressed)"; "tar (uncompressed)"] in
 500   let combo, _ = GEdit.combo_box_text ~strings ~active:0 () in
 501   dlg#set_extra_widget (combo :> GObj.widget);
 502
 503   dlg#show ()
 504
 505 and export_checksums_dialog tree path0 () =
 506   (* XXX NOT IMPL XXX *)
 507 (*  let model, _, _, dev, _,_ = tree in
 508   let row = model#get_iter (fst path0) in
 509   let dir = get_pathname tree row in*)
 510
 511   let title = "Choose output file" in
 512   let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
 513
 514   (* Allow the user to select the output algorithm. *)
 515   let strings =
 516     ["crc"; "md5"; "sha1"; "sha224"; "sha256"; "sha384"; "sha512"] in
 517   let combo, _ = GEdit.combo_box_text ~strings ~active:1 () in
 518   dlg#set_extra_widget (combo :> GObj.widget);
 519
 520   dlg#show ()
 521
 522 and export_list_dialog tree path0 () =
 523   (* XXX NOT IMPL XXX *)
 524 (*  let model, _, _, dev, _,_ = tree in
 525   let row = model#get_iter (fst path0) in
 526   let dir = get_pathname tree row in*)
 527
 528   let title = "Choose output file" in
 529   let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
 530
 531   (* Notify that the list of strings is \0 separated. *)
 532   let hbox =
 533     let hbox = GPack.hbox () in
 534     ignore (GMisc.image ~stock:`INFO ~packing:hbox#pack ());
 535     let label = GMisc.label ~text:"The list of filenames is saved to a file with zero byte separators, to allow the full range of characters to be used in the names themselves." ~packing:hbox#pack () in
 536     label#set_line_wrap true;
 537     hbox in
 538   dlg#set_extra_widget (hbox :> GObj.widget);
 539
 540   dlg#show ()
 541
 542 and do_export_dialog tree path0 t =
 543   (* XXX NOT IMPL XXX *)
 544   ()