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 Printf
  21
  22 open Utils
  23 open DeviceSet
  24
  25 module G = Guestfs
  26
  27 type t = {
  28   view : GTree.view;
  29   model : GTree.tree_store;
  30   hash : (int, hdata) Hashtbl.t;    (* hash from index_col -> hdata *)
  31   index_col : int GTree.column;
  32   mode_col : string GTree.column;
  33   name_col : string GTree.column;
  34   size_col : int64 GTree.column;
  35   date_col : string GTree.column;
  36   link_col : string GTree.column;
  37 }
  38
  39 and hdata = state_t * content_t
  40
  41 (* The type of the hidden column used to implement on-demand loading.
  42  * All rows are classified as either nodes or leafs (eg. a "node" might
  43  * be a directory, or a top-level operating system, or anything else
  44  * which the user could open and look inside).
  45  *)
  46 and state_t =
  47   | IsLeaf           (* there are no children *)
  48   | NodeNotStarted   (* user has not tried to open this *)
  49   | NodeLoading      (* user tried to open it, still loading *)
  50   | IsNode           (* we've loaded the children of this directory *)
  51
  52 (* The actual content of a row. *)
  53 and content_t =
  54   | Loading                          (* special "loading ..." node *)
  55   | ErrorMessage of string           (* error message node *)
  56   | Top of Slave.source              (* top level OS or volume node *)
  57   | Directory of Slave.direntry      (* a directory *)
  58   | File of Slave.direntry           (* a file inc. special files *)
  59
  60 let loading_msg = "<i>Loading ...</i>"
  61
  62 let create ~packing () =
  63   let view = GTree.view ~packing () in
  64   (*view#set_rules_hint true;*)
  65   view#selection#set_mode `MULTIPLE;
  66
  67   (* Hash of index numbers -> hdata.  We do this because it's more
  68    * efficient for the GC compared to storing OCaml objects directly in
  69    * the rows.
  70    *)
  71   let hash = Hashtbl.create 1023 in
  72
  73   (* The columns stored in each row.  The hidden [index_col] column is
  74    * an index into the hash table that records everything else about
  75    * this row (see hdata above).  The other display columns, eg.
  76    * [name_col] contain Pango markup and thus have to be escaped.
  77    *)
  78   let cols = new GTree.column_list in
  79   (* Hidden: *)
  80   let index_col = cols#add Gobject.Data.int in
  81   (* Displayed: *)
  82   let mode_col = cols#add Gobject.Data.string in
  83   let name_col = cols#add Gobject.Data.string in
  84   let size_col = cols#add Gobject.Data.int64 in
  85   let date_col = cols#add Gobject.Data.string in
  86   let link_col = cols#add Gobject.Data.string in
  87
  88   (* Create the model. *)
  89   let model = GTree.tree_store cols in
  90   view#set_model (Some (model :> GTree.model));
  91
  92   let renderer = GTree.cell_renderer_text [], ["markup", mode_col] in
  93   let mode_view = GTree.view_column ~title:"Permissions" ~renderer () in
  94   ignore (view#append_column mode_view);
  95
  96   let renderer = GTree.cell_renderer_text [], ["markup", name_col] in
  97   let name_view = GTree.view_column ~title:"Filename" ~renderer () in
  98   name_view#set_max_width 300 (*pixels?!?*);
  99   ignore (view#append_column name_view);
 100
 101   let renderer = GTree.cell_renderer_text [], ["text", size_col] in
 102   let size_view = GTree.view_column ~title:"Size" ~renderer () in
 103   ignore (view#append_column size_view);
 104
 105   let renderer = GTree.cell_renderer_text [], ["markup", date_col] in
 106   let date_view = GTree.view_column ~title:"Date" ~renderer () in
 107   ignore (view#append_column date_view);
 108
 109   let renderer = GTree.cell_renderer_text [], ["markup", link_col] in
 110   let link_view = GTree.view_column ~title:"Link" ~renderer () in
 111   ignore (view#append_column link_view);
 112
 113   { view = view; model = model; hash = hash;
 114     index_col = index_col;
 115     mode_col = mode_col; name_col = name_col; size_col = size_col;
 116     date_col = date_col; link_col = link_col }
 117
 118 let clear { model = model; hash = hash } =
 119   model#clear ();
 120   Hashtbl.clear hash
 121
 122 (* XXX No binding for g_markup_escape in lablgtk2. *)
 123 let markup_escape name =
 124   let f = function
 125     | '&' -> "&amp;" | '<' -> "&lt;" | '>' -> "&gt;"
 126     | c -> String.make 1 c
 127   in
 128   String.replace_chars f name
 129
 130 (* Mark up a filename for the name_col column. *)
 131 let rec markup_of_name name =
 132   markup_escape name
 133
 134 (* Mark up symbolic links. *)
 135 and markup_of_link link =
 136   let link = markup_escape link in
 137   if link <> "" then utf8_rarrow ^ " " ^ link else ""
 138
 139 (* Mark up mode. *)
 140 and markup_of_mode mode =
 141   let c =
 142     if is_socket mode then 's'
 143     else if is_symlink mode then 'l'
 144     else if is_regular_file mode then '-'
 145     else if is_block mode then 'b'
 146     else if is_directory mode then 'd'
 147     else if is_char mode then 'c'
 148     else if is_fifo mode then 'p' else '?' in
 149   let ru = if test_bit 0o400L mode then 'r' else '-' in
 150   let wu = if test_bit 0o200L mode then 'w' else '-' in
 151   let xu = if test_bit 0o100L mode then 'x' else '-' in
 152   let rg = if test_bit 0o40L mode then 'r' else '-' in
 153   let wg = if test_bit 0o20L mode then 'w' else '-' in
 154   let xg = if test_bit 0o10L mode then 'x' else '-' in
 155   let ro = if test_bit 0o4L mode then 'r' else '-' in
 156   let wo = if test_bit 0o2L mode then 'w' else '-' in
 157   let xo = if test_bit 0o1L mode then 'x' else '-' in
 158   let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
 159
 160   let suid = test_bit 0o4000L mode in
 161   let sgid = test_bit 0o2000L mode in
 162   let svtx = test_bit 0o1000L mode in
 163   if suid then str.[3] <- 's';
 164   if sgid then str.[6] <- 's';
 165   if svtx then str.[9] <- 't';
 166
 167   "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
 168
 169 (* File type tests. *)
 170 and file_type mask mode = Int64.logand mode 0o170000L = mask
 171
 172 and is_socket mode =       file_type 0o140000L mode
 173 and is_symlink mode =      file_type 0o120000L mode
 174 and is_regular_file mode = file_type 0o100000L mode
 175 and is_block mode =        file_type 0o060000L mode
 176 and is_directory mode =    file_type 0o040000L mode
 177 and is_char mode =         file_type 0o020000L mode
 178 and is_fifo mode =         file_type 0o010000L mode
 179
 180 and test_bit mask mode = Int64.logand mode mask = mask
 181
 182 (* Mark up dates. *)
 183 and markup_of_date time =
 184   let time = Int64.to_float time in
 185   let tm = Unix.localtime time in
 186   sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
 187     (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
 188     tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
 189
 190 (* Store hdata into a row. *)
 191 let store_hdata {model = model; hash = hash; index_col = index_col} row hdata =
 192   let index = unique () in
 193   Hashtbl.add hash index hdata;
 194   model#set ~row ~column:index_col index
 195
 196 (* Retrieve previously stored hdata from a row. *)
 197 let get_hdata { model = model; hash = hash; index_col = index_col } row =
 198   let index = model#get ~row ~column:index_col in
 199   try Hashtbl.find hash index
 200   with Not_found -> assert false
 201
 202 let rec add ({ model = model; hash = hash } as t) name data =
 203   clear t;
 204
 205   (* Populate the top level of the filetree.  If there are operating
 206    * systems from inspection, these have their own top level entries
 207    * followed by only unreferenced filesystems.  If we didn't get
 208    * anything from inspection, then at the top level we just show
 209    * filesystems.
 210    *)
 211   let other_filesystems =
 212     DeviceSet.of_list (List.map fst data.Slave.insp_all_filesystems) in
 213   let other_filesystems =
 214     List.fold_left (fun set { Slave.insp_filesystems = fses } ->
 215                       DeviceSet.subtract set (DeviceSet.of_array fses))
 216       other_filesystems data.Slave.insp_oses in
 217
 218   (* Add top level operating systems. *)
 219   List.iter (add_top_level_os t name) data.Slave.insp_oses;
 220
 221   (* Add top level left-over filesystems. *)
 222   DeviceSet.iter (add_top_level_vol t name) other_filesystems;
 223
 224   (* Expand the first top level node. *)
 225   match model#get_iter_first with
 226   | None -> ()
 227   | Some row ->
 228       t.view#expand_row (model#get_path row)
 229
 230 and add_top_level_os ({ model = model; hash = hash } as t) name os =
 231   let markup =
 232     sprintf "<b>%s</b>\n<small>%s</small>\n<small>%s</small>"
 233       (markup_escape name) (markup_escape os.Slave.insp_hostname)
 234       (markup_escape os.Slave.insp_product_name) in
 235
 236   let row = model#append () in
 237   make_node t row (Top (Slave.OS os));
 238   model#set ~row ~column:t.name_col markup
 239
 240 and add_top_level_vol ({ model = model; hash = hash } as t) name dev =
 241   let markup =
 242     sprintf "<b>%s</b>\n<small>from %s</small>"
 243       (markup_escape dev) (markup_escape name) in
 244
 245   let row = model#append () in
 246   make_node t row (Top (Slave.Volume dev));
 247   model#set ~row ~column:t.name_col markup
 248
 249 (* Generic function to make an openable node to the tree. *)
 250 and make_node ({ model = model; hash = hash } as t) row content =
 251   let hdata = NodeNotStarted, content in
 252   store_hdata t row hdata;
 253
 254   (* Create a placeholder "loading ..." row underneath this node so
 255    * the user has something to expand.
 256    *)
 257   let placeholder = model#append ~parent:row () in
 258   let hdata = IsLeaf, Loading in
 259   store_hdata t placeholder hdata;
 260   model#set ~row:placeholder ~column:t.name_col loading_msg;
 261   ignore (t.view#connect#row_expanded ~callback:(expand_row t))
 262
 263 and make_leaf ({ model = model; hash = hash } as t) row content =
 264   let hdata = IsLeaf, content in
 265   store_hdata t row hdata
 266
 267 (* This is called when the user expands a row. *)
 268 and expand_row ({ model = model; hash = hash } as t) row _ =
 269   match get_hdata t row with
 270   | NodeNotStarted, Top src ->
 271       (* User has opened a top level node that was not previously opened. *)
 272
 273       (* Mark this row as loading, so we don't try to open it again. *)
 274       let hdata = NodeLoading, Top src in
 275       store_hdata t row hdata;
 276
 277       (* Get a stable path for this row. *)
 278       let path = model#get_path row in
 279
 280       Slave.read_directory ~fail:(when_read_directory_fail t path)
 281         src "/" (when_read_directory t path)
 282
 283   | NodeNotStarted, Directory direntry ->
 284       (* User has opened a filesystem directory not previously opened. *)
 285
 286       (* Mark this row as loading. *)
 287       let hdata = NodeLoading, Directory direntry in
 288       store_hdata t row hdata;
 289
 290       (* Get a stable path for this row. *)
 291       let path = model#get_path row in
 292
 293       let src, pathname = get_pathname t row in
 294
 295       Slave.read_directory ~fail:(when_read_directory_fail t path)
 296         src pathname (when_read_directory t path)
 297
 298   | NodeLoading, _ | IsNode, _ -> ()
 299
 300   (* These are not nodes so it should never be possible to open them. *)
 301   | _, File _ | IsLeaf, _ -> assert false
 302
 303   (* Node should not exist in the tree. *)
 304   | NodeNotStarted, (Loading | ErrorMessage _) -> assert false
 305
 306 (* Search up to the top of the tree so we know if this directory
 307  * comes from an OS or a volume, and the full path to here.
 308  *
 309  * The path up the tree will always look something like:
 310  *     Top
 311  *       \_ Directory
 312  *            \_ Directory
 313  *                 \_ Loading    <--- you are here
 314  *)
 315 and get_pathname ({ model = model } as t) row =
 316   let hdata = get_hdata t row in
 317   let parent = model#iter_parent row in
 318
 319   match hdata, parent with
 320   | (IsLeaf, Loading), Some parent ->
 321       get_pathname t parent
 322   | (IsLeaf, Loading), None ->
 323       assert false
 324   | (_, Directory { Slave.dent_name = name }), Some parent
 325   | (_, File { Slave.dent_name = name }), Some parent ->
 326       let src, parent_name = get_pathname t parent in
 327       let path =
 328         if parent_name = "/" then "/" ^ name
 329         else parent_name ^ "/" ^ name in
 330       src, path
 331   | (_, Top src), _ -> src, "/"
 332   | (_, Directory _), None -> assert false
 333   | (_, File _), None -> assert false
 334   | (_, Loading), _ -> assert false
 335   | (_, ErrorMessage _), _ -> assert false
 336
 337 (* This is the callback when the slave has read the directory for us. *)
 338 and when_read_directory ({ model = model } as t) path entries =
 339   debug "when_read_directory";
 340
 341   let row = model#get_iter path in
 342
 343   (* Add the entries. *)
 344   List.iter (
 345     fun direntry ->
 346       let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
 347         direntry in
 348       let row = model#append ~parent:row () in
 349       if is_directory stat.G.mode then
 350         make_node t row (Directory direntry)
 351       else
 352         make_leaf t row (File direntry);
 353       model#set ~row ~column:t.name_col (markup_of_name name);
 354       model#set ~row ~column:t.mode_col (markup_of_mode stat.G.mode);
 355       model#set ~row ~column:t.size_col stat.G.size;
 356       model#set ~row ~column:t.date_col (markup_of_date stat.G.mtime);
 357       model#set ~row ~column:t.link_col (markup_of_link link)
 358   ) entries;
 359
 360   (* Remove the placeholder entry.  NB. Must be done AFTER adding
 361    * the other entries, or else Gtk will unexpand the row.
 362    *)
 363   (try
 364      let placeholder = model#iter_children ~nth:0 (Some row) in
 365      ignore (model#remove placeholder)
 366    with Invalid_argument _ -> ()
 367   );
 368
 369   (* The original directory entry has now been loaded, so
 370    * update its state.
 371    *)
 372   let state, content = get_hdata t row in
 373   let hdata = IsNode, content in
 374   store_hdata t row hdata
 375
 376 (* This is called instead of when_read_directory when the read directory
 377  * (or mount etc) failed.  Convert the "Loading" entry into the
 378  * error message.
 379  *)
 380 and when_read_directory_fail ({ model = model } as t) path exn =
 381   debug "when_read_directory_fail: %s" (Printexc.to_string exn);
 382
 383   match exn with
 384   | G.Error msg ->
 385       let row = model#get_iter path in
 386       let row = model#iter_children ~nth:0 (Some row) in
 387
 388       let hdata = IsLeaf, ErrorMessage msg in
 389       store_hdata t row hdata;
 390
 391       model#set ~row ~column:t.name_col (markup_escape msg)
 392
 393   | exn ->
 394       (* unexpected exception: re-raise it *)
 395       raise exn