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