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 Unix
  22 open Printf
  23
  24 open Utils
  25 open DeviceSet
  26 open Slave_types
  27
  28 open Filetree_type
  29 open Filetree_markup
  30 open Filetree_ops
  31
  32 module G = Guestfs
  33
  34 type t = Filetree_type.t
  35
  36 (* Temporary directory for shared use by any function in this file.
  37  * It is cleaned up when the program exits.
  38  *)
  39 let tmpdir = tmpdir ()
  40
  41 let rec create ~packing () =
  42   let view = GTree.view ~packing () in
  43   (*view#set_rules_hint true;*)
  44   (*view#selection#set_mode `MULTIPLE; -- add this later *)
  45
  46   (* Hash of index numbers -> hdata.  We do this because it's more
  47    * efficient for the GC compared to storing OCaml objects directly in
  48    * the rows.
  49    *)
  50   let hash = Hashtbl.create 1023 in
  51
  52   (* The columns stored in each row.  The hidden [index_col] column is
  53    * an index into the hash table that records everything else about
  54    * this row (see hdata above).  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 index_col = cols#add Gobject.Data.int in
  60   (* Displayed: *)
  61   let mode_col = cols#add Gobject.Data.string in
  62   let name_col = cols#add Gobject.Data.string in
  63   let size_col = cols#add Gobject.Data.string in
  64   let date_col = cols#add Gobject.Data.string in
  65
  66   (* Create the model. *)
  67   let model = GTree.tree_store cols in
  68
  69   (* Create the view. *)
  70   view#set_model (Some (model :> GTree.model));
  71
  72   let renderer = GTree.cell_renderer_text [], ["markup", mode_col] in
  73   let mode_view = GTree.view_column ~title:"Permissions" ~renderer () in
  74   mode_view#set_resizable true;
  75   ignore (view#append_column mode_view);
  76
  77   let renderer = GTree.cell_renderer_text [], ["markup", name_col] in
  78   let name_view = GTree.view_column ~title:"Filename" ~renderer () in
  79   name_view#set_resizable true;
  80   name_view#set_sizing `AUTOSIZE;
  81   ignore (view#append_column name_view);
  82
  83   let renderer = GTree.cell_renderer_text [`XALIGN 1.], ["markup", size_col] in
  84   let size_view = GTree.view_column ~title:"Size" ~renderer () in
  85   size_view#set_resizable true;
  86   ignore (view#append_column size_view);
  87
  88   let renderer = GTree.cell_renderer_text [`XALIGN 1.], ["markup", date_col] in
  89   let date_view = GTree.view_column ~title:"Date" ~renderer () in
  90   date_view#set_resizable true;
  91   ignore (view#append_column date_view);
  92
  93   let t = {
  94     view = view; model = model; hash = hash;
  95     index_col = index_col;
  96     mode_col = mode_col; name_col = name_col; size_col = size_col;
  97     date_col = date_col;
  98   } in
  99
 100   (* Open a context menu when a button is pressed. *)
 101   ignore (view#event#connect#button_press ~callback:(button_press t));
 102
 103   t
 104
 105 (* Handle mouse button press on the selected row.  This opens the
 106  * pop-up context menu.
 107  * http://scentric.net/tutorial/sec-selections-context-menus.html
 108  *)
 109 and button_press ({ model = model; view = view } as t) ev =
 110   let button = GdkEvent.Button.button ev in
 111   let x = int_of_float (GdkEvent.Button.x ev) in
 112   let y = int_of_float (GdkEvent.Button.y ev) in
 113   let time = GdkEvent.Button.time ev in
 114
 115   (* Right button for opening the context menu. *)
 116   if button = 3 then (
 117 (*
 118     (* If no row is selected, select the row under the mouse. *)
 119     let paths =
 120       let sel = view#selection in
 121       if sel#count_selected_rows < 1 then (
 122         match view#get_path_at_pos ~x ~y with
 123         | None -> []
 124         | Some (path, _, _, _) ->
 125             sel#unselect_all ();
 126             sel#select_path path;
 127             [path]
 128       ) else
 129         sel#get_selected_rows (* actually returns paths *) in
 130 *)
 131     (* Select the row under the mouse. *)
 132     let paths =
 133       let sel = view#selection in
 134       match view#get_path_at_pos ~x ~y with
 135       | None -> []
 136       | Some (path, _, _, _) ->
 137           sel#unselect_all ();
 138           sel#select_path path;
 139           [path] in
 140
 141     (* Get the hdata for all the paths.  Filter out rows that it doesn't
 142      * make sense to select.
 143      *)
 144     let paths =
 145       List.filter_map (
 146         fun path ->
 147           let row = model#get_iter path in
 148           let hdata = get_hdata t row in
 149           match hdata with
 150           | { content=(Loading | ErrorMessage _ | Info _) } -> None
 151           | { content=(Top _ | Directory _ | File _ |
 152                            TopWinReg _ | RegKey _ | RegValue _ ) } ->
 153               Some (path, hdata)
 154       ) paths in
 155
 156     (* Based on number of selected rows and what is selected, construct
 157      * the context menu.
 158      *)
 159     (match make_context_menu t paths with
 160      | Some menu -> menu#popup ~button ~time
 161      | None -> ()
 162     );
 163
 164     (* Return true so no other handler will run. *)
 165     true
 166   )
 167   (* We didn't handle this, defer to other handlers. *)
 168   else false
 169
 170 and make_context_menu t paths =
 171   let menu = GMenu.menu () in
 172   let factory = new GMenu.factory menu in
 173
 174   let rec add_file_items path =
 175     let item = factory#add_item "View ..." in
 176     (match Config.opener with
 177      | Some opener ->
 178          ignore (item#connect#activate ~callback:(view_file t path opener));
 179      | None ->
 180          item#misc#set_sensitive false
 181     );
 182     let item = factory#add_item "File information" in
 183     ignore (item#connect#activate ~callback:(file_information t path));
 184     let item = factory#add_item "MD5 checksum" in
 185     ignore (item#connect#activate ~callback:(checksum_file t path "md5"));
 186     let item = factory#add_item "SHA1 checksum" in
 187     ignore (item#connect#activate ~callback:(checksum_file t path "sha1"));
 188     ignore (factory#add_separator ());
 189     let item = factory#add_item "Download ..." in
 190     ignore (item#connect#activate ~callback:(download_file t path));
 191
 192   and add_directory_items path =
 193     let item = factory#add_item "Directory information" in
 194     item#misc#set_sensitive false;
 195     let item = factory#add_item "Calculate disk usage" in
 196     ignore (item#connect#activate ~callback:(disk_usage t path));
 197     ignore (factory#add_separator ());
 198     let item = factory#add_item "Download ..." in
 199     item#misc#set_sensitive false;
 200     let item = factory#add_item "Download as .tar ..." in
 201     ignore (item#connect#activate
 202               ~callback:(download_dir_tarball t Tar path));
 203     let item = factory#add_item "Download as .tar.gz ..." in
 204     ignore (item#connect#activate
 205               ~callback:(download_dir_tarball t TGZ path));
 206     let item = factory#add_item "Download as .tar.xz ..." in
 207     ignore (item#connect#activate
 208               ~callback:(download_dir_tarball t TXZ path));
 209     let item = factory#add_item "Download list of filenames ..." in
 210     ignore (item#connect#activate ~callback:(download_dir_find0 t path));
 211
 212   and add_top_os_items path =
 213     let item = factory#add_item "Operating system information" in
 214     ignore (item#connect#activate ~callback:(display_inspection_data t path));
 215     ignore (factory#add_separator ());
 216     add_top_volume_items path
 217
 218   and add_top_volume_items path =
 219     let item = factory#add_item "Filesystem used & free" in
 220     item#misc#set_sensitive false;
 221     let item = factory#add_item "Block device information" in
 222     item#misc#set_sensitive false;
 223     ignore (factory#add_separator ());
 224     add_directory_items path
 225
 226   and add_topwinreg_items path =
 227     let item = factory#add_item "Download hive file ..." in
 228     item#misc#set_sensitive false;
 229     ignore (factory#add_separator ());
 230     add_regkey_items path
 231
 232   and add_regkey_items path =
 233     let item = factory#add_item "Download as .reg file ..." in
 234     (match Config.hivexregedit with
 235      | Some hivexregedit ->
 236          ignore (item#connect#activate
 237                    ~callback:(download_as_reg t path hivexregedit));
 238      | None ->
 239          item#misc#set_sensitive false
 240     )
 241
 242   and add_regvalue_items path =
 243     let item = factory#add_item "Copy value to clipboard" in
 244     ignore (item#connect#activate ~callback:(copy_regvalue t path));
 245
 246   in
 247
 248   let has_menu =
 249     match paths with
 250     | [] -> false
 251
 252     (* single selection *)
 253     | [path, { content=Top (OS os)} ] ->  (* top level operating system *)
 254         add_top_os_items path; true
 255
 256     | [path, { content=Top (Volume dev) }] -> (* top level volume *)
 257         add_top_volume_items path; true
 258
 259     | [path, { content=Directory _ }] -> (* directory *)
 260         add_directory_items path; true
 261
 262     | [path, { content=File _ }] ->      (* file *)
 263         add_file_items path; true
 264
 265     | [path, { content=TopWinReg _ }] -> (* top level registry node *)
 266         add_topwinreg_items path; true
 267
 268     | [path, { content=RegKey _ }] ->    (* registry node *)
 269         add_regkey_items path; true
 270
 271     | [path, { content=RegValue _ }] ->  (* registry key/value pair *)
 272         add_regvalue_items path; true
 273
 274     | [_, { content=(Loading|ErrorMessage _|Info _) }] -> false
 275
 276     | _::_::_ ->
 277         (* At the moment multiple selection is disabled.  When/if we
 278          * enable it we should do something intelligent here. XXX
 279          *)
 280         false in
 281   if has_menu then Some menu else None
 282
 283 let clear { model = model; hash = hash } =
 284   model#clear ();
 285   Hashtbl.clear hash
 286
 287 let rec add ({ model = model } as t) name data =
 288   clear t;
 289
 290   (* Populate the top level of the filetree.  If there are operating
 291    * systems from inspection, these have their own top level entries
 292    * followed by only unreferenced filesystems.  If we didn't get
 293    * anything from inspection, then at the top level we just show
 294    * filesystems.
 295    *)
 296   let other_filesystems =
 297     DeviceSet.of_list (List.map fst data.insp_all_filesystems) in
 298   let other_filesystems =
 299     List.fold_left (fun set { insp_filesystems = fses } ->
 300                       DeviceSet.subtract set (DeviceSet.of_array fses))
 301       other_filesystems data.insp_oses in
 302
 303   (* Add top level operating systems. *)
 304   List.iter (add_top_level_os t name) data.insp_oses;
 305
 306   (* Add top level left-over filesystems. *)
 307   DeviceSet.iter (add_top_level_vol t name) other_filesystems;
 308
 309   (* If it's Windows and registry files exist, create a node for
 310    * each file.
 311    *)
 312   List.iter (
 313     fun os ->
 314       (match os.insp_winreg_SAM with
 315        | Some filename ->
 316            add_top_level_winreg t name os "HKEY_LOCAL_MACHINE\\SAM" filename
 317        | None -> ()
 318       );
 319       (match os.insp_winreg_SECURITY with
 320        | Some filename ->
 321            add_top_level_winreg t name os "HKEY_LOCAL_MACHINE\\SECURITY"
 322              filename
 323        | None -> ()
 324       );
 325       (match os.insp_winreg_SOFTWARE with
 326        | Some filename ->
 327            add_top_level_winreg t name os "HKEY_LOCAL_MACHINE\\SOFTWARE"
 328              filename
 329        | None -> ()
 330       );
 331       (match os.insp_winreg_SYSTEM with
 332        | Some filename ->
 333            add_top_level_winreg t name os "HKEY_LOCAL_MACHINE\\SYSTEM"
 334              filename
 335        | None -> ()
 336       );
 337       (match os.insp_winreg_DEFAULT with
 338        | Some filename ->
 339            add_top_level_winreg t name os "HKEY_USERS\\.DEFAULT" filename
 340        | None -> ()
 341       );
 342   ) data.insp_oses;
 343
 344   (* Expand the first top level node. *)
 345   match model#get_iter_first with
 346   | None -> ()
 347   | Some row ->
 348       t.view#expand_row (model#get_path row)
 349
 350 (* Add a top level operating system node. *)
 351 and add_top_level_os ({ model = model } as t) name os =
 352   let markup =
 353     sprintf "<b>%s</b>\n<small>%s</small>\n<small>%s</small>"
 354       (markup_escape name) (markup_escape os.insp_hostname)
 355       (markup_escape os.insp_product_name) in
 356
 357   let row = model#append () in
 358   make_node t row (Top (OS os)) None;
 359   model#set ~row ~column:t.name_col markup
 360
 361 (* Add a top level volume (left over filesystem) node. *)
 362 and add_top_level_vol ({ model = model } as t) name dev =
 363   let markup =
 364     sprintf "<b>%s</b>\n<small>from %s</small>"
 365       (markup_escape dev) (markup_escape name) in
 366
 367   let row = model#append () in
 368   make_node t row (Top (Volume dev)) None;
 369   model#set ~row ~column:t.name_col markup
 370
 371 (* Add a top level Windows Registry node. *)
 372 and add_top_level_winreg ({ model = model } as t) name os rootkey
 373     remotefile =
 374   let cachefile = tmpdir // string_of_int (unique ()) ^ ".hive" in
 375
 376   let markup =
 377     sprintf "<b>%s</b>\n<small>from %s</small>"
 378       (markup_escape rootkey) (markup_escape name) in
 379
 380   let row = model#append () in
 381   make_node t row
 382     (TopWinReg (OS os, rootkey, remotefile, cachefile)) None;
 383   model#set ~row ~column:t.name_col markup
 384
 385 (* Generic function to make an openable node to the tree. *)
 386 and make_node ({ model = model } as t) row content hiveh =
 387   let hdata =
 388     { state=NodeNotStarted; content=content; visited=false; hiveh=hiveh } in
 389   store_hdata t row hdata;
 390
 391   (* Create a placeholder "loading ..." row underneath this node so
 392    * the user has something to expand.
 393    *)
 394   let placeholder = model#append ~parent:row () in
 395   let hdata = { state=IsLeaf; content=Loading; visited=false; hiveh=None } in
 396   store_hdata t placeholder hdata;
 397   model#set ~row:placeholder ~column:t.name_col "<i>Loading ...</i>";
 398   ignore (t.view#connect#row_expanded ~callback:(expand_row t))
 399
 400 and make_leaf ({ model = model } as t) row content hiveh =
 401   let hdata = { state=IsLeaf; content=content; visited=false; hiveh=hiveh } in
 402   store_hdata t row hdata
 403
 404 (* This is called when the user expands a row. *)
 405 and expand_row ({ model = model } as t) row _ =
 406   match get_hdata t row with
 407   | { state=NodeNotStarted; content=Top src } as hdata ->
 408       (* User has opened a top level node that was not previously opened. *)
 409
 410       (* Mark this row as loading, so we don't try to open it again. *)
 411       hdata.state <- NodeLoading;
 412
 413       (* Get a stable path for this row. *)
 414       let path = model#get_path row in
 415
 416       Slave.read_directory ~fail:(when_read_directory_fail t path)
 417         src "/" (when_read_directory t path)
 418
 419   | { state=NodeNotStarted; content=Directory direntry } as hdata ->
 420       (* User has opened a filesystem directory not previously opened. *)
 421
 422       (* Mark this row as loading. *)
 423       hdata.state <- NodeLoading;
 424
 425       (* Get a stable path for this row. *)
 426       let path = model#get_path row in
 427
 428       let src, pathname = get_pathname t row in
 429
 430       Slave.read_directory ~fail:(when_read_directory_fail t path)
 431         src pathname (when_read_directory t path)
 432
 433   | { state=NodeNotStarted;
 434       content=TopWinReg (src, rootkey, remotefile, cachefile) } as hdata ->
 435       (* User has opened a Windows Registry top level node
 436        * not previously opened.
 437        *)
 438
 439       (* Mark this row as loading. *)
 440       hdata.state <- NodeLoading;
 441
 442       (* Get a stable path for this row. *)
 443       let path = model#get_path row in
 444
 445       (* Since the user has opened this top level registry node for the
 446        * first time, we now need to download the hive.
 447        *)
 448       cache_registry_file ~fail:(when_downloaded_registry_fail t path)
 449         t path src remotefile cachefile (when_downloaded_registry t path)
 450
 451   | { state=NodeNotStarted; content=RegKey node } as hdata ->
 452       (* User has opened a Windows Registry key node not previously opened. *)
 453
 454       (* Mark this row as loading. *)
 455       hdata.state <- NodeLoading;
 456
 457       expand_hive_node t row node
 458
 459   (* Ignore when a user opens a node which is loading or has been loaded. *)
 460   | { state=(NodeLoading|IsNode) } -> ()
 461
 462   (* In some circumstances these can be nodes, eg. if we have added Info
 463    * nodes below them.  Just ignore them if opened.
 464    *)
 465   | { content=(File _ | RegValue _) } | { state=IsLeaf } -> ()
 466
 467   (* Node should not exist in the tree. *)
 468   | { state=NodeNotStarted; content=(Loading | ErrorMessage _ | Info _) } ->
 469       assert false
 470
 471 (* This is the callback when the slave has read the directory for us. *)
 472 and when_read_directory ({ model = model } as t) path entries =
 473   debug "when_read_directory";
 474
 475   let row = model#get_iter path in
 476
 477   (* Sort the entries by lexicographic ordering. *)
 478   let cmp { dent_name = n1 } { dent_name = n2 } =
 479     UTF8.compare n1 n2
 480   in
 481   let entries = List.sort ~cmp entries in
 482
 483   (* Add the entries. *)
 484   List.iter (
 485     fun direntry ->
 486       let { dent_name = name; dent_stat = stat; dent_link = link } =
 487         direntry in
 488       let row = model#append ~parent:row () in
 489       if is_directory stat.G.mode then
 490         make_node t row (Directory direntry) None
 491       else
 492         make_leaf t row (File direntry) None;
 493       model#set ~row ~column:t.name_col (markup_of_name direntry);
 494       model#set ~row ~column:t.mode_col (markup_of_mode stat.G.mode);
 495       model#set ~row ~column:t.size_col (markup_of_size stat.G.size);
 496       model#set ~row ~column:t.date_col (markup_of_date stat.G.mtime);
 497   ) entries;
 498
 499   (* Remove the placeholder "Loading" entry.  NB. Must be done AFTER
 500    * adding the other entries, or else Gtk will unexpand the row.
 501    *)
 502   (try
 503      let row = find_child_node_by_content t row Loading in
 504      ignore (model#remove row)
 505    with Invalid_argument _ | Not_found -> ()
 506   );
 507
 508   (* The original directory entry has now been loaded, so
 509    * update its state.
 510    *)
 511   let hdata = get_hdata t row in
 512   hdata.state <- IsNode;
 513   set_visited t row
 514
 515 (* This is called instead of when_read_directory when the read directory
 516  * (or mount etc) failed.  Convert the "Loading" entry into the
 517  * error message.
 518  *)
 519 and when_read_directory_fail ({ model = model } as t) path exn =
 520   debug "when_read_directory_fail: %s" (Printexc.to_string exn);
 521
 522   match exn with
 523   | G.Error msg ->
 524       let row = model#get_iter path in
 525       let row = model#iter_children ~nth:0 (Some row) in
 526
 527       let hdata =
 528         { state=IsLeaf; content=ErrorMessage msg; visited=false; hiveh=None } in
 529       store_hdata t row hdata;
 530
 531       model#set ~row ~column:t.name_col (markup_escape msg)
 532
 533   | exn ->
 534       (* unexpected exception: re-raise it *)
 535       raise exn
 536
 537 (* Called when the top level registry node has been opened and the
 538  * hive file was downloaded to the cache file successfully.
 539  *)
 540 and when_downloaded_registry ({ model = model } as t) path () =
 541   debug "when_downloaded_registry";
 542   let row = model#get_iter path in
 543   let hdata = get_hdata t row in
 544   let h = Option.get hdata.hiveh in
 545
 546   (* Continue as if expanding any other hive node. *)
 547   let root = Hivex.root h in
 548   expand_hive_node t row root
 549
 550 (* Called instead of {!when_downloaded_registry} if the download failed. *)
 551 and when_downloaded_registry_fail ({ model = model } as t) path exn =
 552   debug "when_downloaded_registry_fail: %s" (Printexc.to_string exn);
 553
 554   match exn with
 555   | G.Error msg
 556   | Hivex.Error (_, _, msg) ->
 557       let row = model#get_iter path in
 558       let row = model#iter_children ~nth:0 (Some row) in
 559
 560       let hdata =
 561         { state=IsLeaf; content=ErrorMessage msg; visited=false; hiveh=None } in
 562       store_hdata t row hdata;
 563
 564       model#set ~row ~column:t.name_col (markup_escape msg)
 565
 566   | exn ->
 567       (* unexpected exception: re-raise it *)
 568       raise exn
 569
 570 (* Expand a hive node. *)
 571 and expand_hive_node ({ model = model } as t) row node =
 572   debug "expand_hive_node";
 573   let hdata = get_hdata t row in
 574   let h = Option.get hdata.hiveh in
 575
 576   (* Read the hive entries (values, subkeys) at this node and add them
 577    * to the tree.
 578    *)
 579   let values = Hivex.node_values h node in
 580   let cmp v1 v2 = UTF8.compare (Hivex.value_key h v1) (Hivex.value_key h v2) in
 581   Array.sort cmp values;
 582   Array.iter (
 583     fun value ->
 584       let row = model#append ~parent:row () in
 585       make_leaf t row (RegValue value) (Some h);
 586       model#set ~row ~column:t.name_col (markup_of_regvalue h value);
 587       model#set ~row ~column:t.size_col (markup_of_regvaluesize h value);
 588       model#set ~row ~column:t.date_col (markup_of_regvaluetype h value);
 589   ) values;
 590
 591   let children = Hivex.node_children h node in
 592   let cmp n1 n2 = UTF8.compare (Hivex.node_name h n1) (Hivex.node_name h n2) in
 593   Array.sort cmp children;
 594   Array.iter (
 595     fun node ->
 596       let row = model#append ~parent:row () in
 597       make_node t row (RegKey node) (Some h);
 598       model#set ~row ~column:t.name_col (markup_of_regkey h node);
 599   ) children;
 600
 601   (* Remove the placeholder "Loading" entry.  NB. Must be done AFTER
 602    * adding the other entries, or else Gtk will unexpand the row.
 603    *)
 604   (try
 605      let row = find_child_node_by_content t row Loading in
 606      ignore (model#remove row)
 607    with Invalid_argument _ | Not_found -> ()
 608   );
 609
 610   (* The original entry has now been loaded, so update its state. *)
 611   hdata.state <- IsNode;
 612   set_visited t row