[guestfs-browser.git] / filetree.ml

(* Guestfs Browser.
 * Copyright (C) 2010 Red Hat Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this program; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

open ExtString
open Printf

open Utils
open DeviceSet

module G = Guestfs

type t = {
  view : GTree.view;
  model : GTree.tree_store;
  hash : (int, hdata) Hashtbl.t;    (* hash from index_col -> hdata *)
  index_col : int GTree.column;
  mode_col : string GTree.column;
  name_col : string GTree.column;
  size_col : int64 GTree.column;
  date_col : string GTree.column;
  link_col : string GTree.column;
}

and hdata = state_t * content_t

(* The type of the hidden column used to implement on-demand loading.
 * All rows are classified as either nodes or leafs (eg. a "node" might
 * be a directory, or a top-level operating system, or anything else
 * which the user could open and look inside).
 *)
and state_t =
  | IsLeaf           (* there are no children *)
  | NodeNotStarted   (* user has not tried to open this *)
  | NodeLoading      (* user tried to open it, still loading *)
  | IsNode           (* we've loaded the children of this directory *)
  | Loading          (* special row contains the "Loading ..." message *)

(* The actual content of a row. *)
and content_t =
  | NoContent
  | Top of Slave.source              (* top level OS or volume node *)
  | Directory of Slave.direntry      (* a directory *)
  | File of Slave.direntry           (* a file inc. special files *)

let loading_msg = "<i>Loading ...</i>"

let create ~packing () =
  let view = GTree.view ~packing () in
  (*view#set_rules_hint true;*)
  view#selection#set_mode `MULTIPLE;

  (* Hash of index numbers -> hdata.  We do this because it's more
   * efficient for the GC compared to storing OCaml objects directly in
   * the rows.
   *)
  let hash = Hashtbl.create 1023 in

  (* The columns stored in each row.  The hidden [index_col] column is
   * an index into the hash table that records everything else about
   * this row (see hdata above).  The other display columns, eg.
   * [name_col] contain Pango markup and thus have to be escaped.
   *)
  let cols = new GTree.column_list in
  (* Hidden: *)
  let index_col = cols#add Gobject.Data.int in
  (* Displayed: *)
  let mode_col = cols#add Gobject.Data.string in
  let name_col = cols#add Gobject.Data.string in
  let size_col = cols#add Gobject.Data.int64 in
  let date_col = cols#add Gobject.Data.string in
  let link_col = cols#add Gobject.Data.string in

  (* Create the model. *)
  let model = GTree.tree_store cols in
  view#set_model (Some (model :> GTree.model));

  let renderer = GTree.cell_renderer_text [], ["markup", mode_col] in
  let mode_view = GTree.view_column ~title:"Permissions" ~renderer () in
  ignore (view#append_column mode_view);

  let renderer = GTree.cell_renderer_text [], ["markup", name_col] in
  let name_view = GTree.view_column ~title:"Filename" ~renderer () in
  name_view#set_max_width 400 (*pixels?!?*);
  ignore (view#append_column name_view);

  let renderer = GTree.cell_renderer_text [], ["text", size_col] in
  let size_view = GTree.view_column ~title:"Size" ~renderer () in
  ignore (view#append_column size_view);

  let renderer = GTree.cell_renderer_text [], ["markup", date_col] in
  let date_view = GTree.view_column ~title:"Date" ~renderer () in
  ignore (view#append_column date_view);

  let renderer = GTree.cell_renderer_text [], ["markup", link_col] in
  let link_view = GTree.view_column ~title:"Link" ~renderer () in
  ignore (view#append_column link_view);

  { view = view; model = model; hash = hash;
    index_col = index_col;
    mode_col = mode_col; name_col = name_col; size_col = size_col;
    date_col = date_col; link_col = link_col }

let clear { model = model; hash = hash } =
  model#clear ();
  Hashtbl.clear hash

(* XXX No binding for g_markup_escape in lablgtk2. *)
let markup_escape name =
  let f = function
    | '&' -> "&amp;" | '<' -> "&lt;" | '>' -> "&gt;"
    | c -> String.make 1 c
  in
  String.replace_chars f name

(* Mark up a filename for the name_col column. *)
let rec markup_of_name name =
  markup_escape name

(* Mark up symbolic links. *)
and markup_of_link link =
  let link = markup_escape link in
  if link <> "" then utf8_rarrow ^ " " ^ link else ""

(* Mark up mode. *)
and markup_of_mode mode =
  let c =
    if is_socket mode then 's'
    else if is_symlink mode then 'l'
    else if is_regular_file mode then '-'
    else if is_block mode then 'b'
    else if is_directory mode then 'd'
    else if is_char mode then 'c'
    else if is_fifo mode then 'p' else '?' in
  let ru = if test_bit 0o400L mode then 'r' else '-' in
  let wu = if test_bit 0o200L mode then 'w' else '-' in
  let xu = if test_bit 0o100L mode then 'x' else '-' in
  let rg = if test_bit 0o40L mode then 'r' else '-' in
  let wg = if test_bit 0o20L mode then 'w' else '-' in
  let xg = if test_bit 0o10L mode then 'x' else '-' in
  let ro = if test_bit 0o4L mode then 'r' else '-' in
  let wo = if test_bit 0o2L mode then 'w' else '-' in
  let xo = if test_bit 0o1L mode then 'x' else '-' in
  let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in

  let suid = test_bit 0o4000L mode in
  let sgid = test_bit 0o2000L mode in
  let svtx = test_bit 0o1000L mode in
  if suid then str.[3] <- 's';
  if sgid then str.[6] <- 's';
  if svtx then str.[9] <- 't';

  "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"

(* File type tests. *)
and file_type mask mode = Int64.logand mode 0o170000L = mask

and is_socket mode =       file_type 0o140000L mode
and is_symlink mode =      file_type 0o120000L mode
and is_regular_file mode = file_type 0o100000L mode
and is_block mode =        file_type 0o060000L mode
and is_directory mode =    file_type 0o040000L mode
and is_char mode =         file_type 0o020000L mode
and is_fifo mode =         file_type 0o010000L mode

and test_bit mask mode = Int64.logand mode mask = mask

(* Mark up dates. *)
and markup_of_date time =
  let time = Int64.to_float time in
  let tm = Unix.localtime time in
  sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
    (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
    tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec

(* Store hdata into a row. *)
let store_hdata {model = model; hash = hash; index_col = index_col} row hdata =
  let index = unique () in
  Hashtbl.add hash index hdata;
  model#set ~row ~column:index_col index

(* Retrieve previously stored hdata from a row. *)
let get_hdata { model = model; hash = hash; index_col = index_col } row =
  let index = model#get ~row ~column:index_col in
  try Hashtbl.find hash index
  with Not_found -> assert false

let rec add ({ model = model; hash = hash } as t) name data =
  clear t;

  (* Populate the top level of the filetree.  If there are operating
   * systems from inspection, these have their own top level entries
   * followed by only unreferenced filesystems.  If we didn't get
   * anything from inspection, then at the top level we just show
   * filesystems.
   *)
  let other_filesystems =
    DeviceSet.of_list (List.map fst data.Slave.insp_all_filesystems) in
  let other_filesystems =
    List.fold_left (fun set { Slave.insp_filesystems = fses } ->
                      DeviceSet.subtract set (DeviceSet.of_array fses))
      other_filesystems data.Slave.insp_oses in

  (* Add top level operating systems. *)
  List.iter (add_top_level_os t name) data.Slave.insp_oses;

  (* Add top level left-over filesystems. *)
  DeviceSet.iter (add_top_level_vol t name) other_filesystems

and add_top_level_os ({ model = model; hash = hash } as t) name os =
  let markup =
    sprintf "<b>%s</b>: %s (%s)"
      (markup_of_name name) (markup_of_name os.Slave.insp_hostname)
      (markup_of_name os.Slave.insp_product_name) in

  let row = model#append () in
  make_node t row (Top (Slave.OS os));
  model#set ~row ~column:t.name_col markup

and add_top_level_vol ({ model = model; hash = hash } as t) name dev =
  let markup =
    sprintf "<b>%s</b>: %s" (markup_of_name name) (markup_of_name dev) in

  let row = model#append () in
  make_node t row (Top (Slave.Volume dev));
  model#set ~row ~column:t.name_col markup

(* Generic function to make an openable node to the tree. *)
and make_node ({ model = model; hash = hash } as t) row content =
  let hdata = NodeNotStarted, content in
  store_hdata t row hdata;

  (* Create a placeholder "loading ..." row underneath this node so
   * the user has something to expand.
   *)
  let placeholder = model#append ~parent:row () in
  let hdata = Loading, NoContent in
  store_hdata t placeholder hdata;
  model#set ~row:placeholder ~column:t.name_col loading_msg;
  ignore (t.view#connect#row_expanded ~callback:(expand_row t))

and make_leaf ({ model = model; hash = hash } as t) row content =
  let hdata = IsLeaf, content in
  store_hdata t row hdata

(* This is called when the user expands a row. *)
and expand_row ({ model = model; hash = hash } as t) row _ =
  match get_hdata t row with
  | NodeNotStarted, Top src ->
      (* User has opened a top level node that was not previously opened. *)

      (* Mark this row as loading, so we don't try to open it again. *)
      let hdata = NodeLoading, Top src in
      store_hdata t row hdata;

      (* Get a stable path for this row. *)
      let path = model#get_path row in

      Slave.read_directory src "/" (when_read_directory t path)

  | NodeNotStarted, Directory direntry ->
      (* User has opened a filesystem directory not previously opened. *)

      (* Mark this row as loading. *)
      let hdata = NodeLoading, Directory direntry in
      store_hdata t row hdata;

      (* Get a stable path for this row. *)
      let path = model#get_path row in

      let src, pathname = get_pathname t row in

      Slave.read_directory src pathname (when_read_directory t path)

  | NodeLoading, _ | IsNode, _ -> ()

  (* These are not nodes so it should never be possible to open them. *)
  | _, File _ | IsLeaf, _ | Loading, _ -> assert false

  (* Should not exist in the tree. *)
  | NodeNotStarted, NoContent -> assert false

(* Search up to the top of the tree so we know if this directory
 * comes from an OS or a volume, and the full path to here.
 *
 * The path up the tree will always look something like:
 *     Top
 *       \_ Directory
 *            \_ Directory
 *                 \_ Loading    <--- you are here
 *)
and get_pathname ({ model = model } as t) row =
  let hdata = get_hdata t row in
  let parent = model#iter_parent row in

  match hdata, parent with
  | (Loading, NoContent), Some parent ->
      get_pathname t parent
  | (Loading, NoContent), None ->
      assert false
  | (_, Directory { Slave.dent_name = name }), Some parent
  | (_, File { Slave.dent_name = name }), Some parent ->
      let src, parent_name = get_pathname t parent in
      let path =
        if parent_name = "/" then "/" ^ name
        else parent_name ^ "/" ^ name in
      src, path
  | (_, Top src), _ -> src, "/"
  | (_, Directory _), None | (_, File _), None -> assert false
  | (_, NoContent), _ -> assert false

(* This is the callback when the slave has read the directory for us. *)
and when_read_directory ({ model = model } as t) path entries =
  debug "when_read_directory";

  let row = model#get_iter path in

  (* Add the entries. *)
  List.iter (
    fun direntry ->
      let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
        direntry in
      let row = model#append ~parent:row () in
      if is_directory stat.G.mode then
        make_node t row (Directory direntry)
      else
        make_leaf t row (File direntry);
      model#set ~row ~column:t.name_col (markup_of_name name);
      model#set ~row ~column:t.mode_col (markup_of_mode stat.G.mode);
      model#set ~row ~column:t.size_col stat.G.size;
      model#set ~row ~column:t.date_col (markup_of_date stat.G.mtime);
      model#set ~row ~column:t.link_col (markup_of_link link)
  ) entries;

  (* Remove the placeholder entry.  NB. Must be done AFTER adding
   * the other entries, or else Gtk will unexpand the row.
   *)
  (try
     let placeholder = model#iter_children ~nth:0 (Some row) in
     ignore (model#remove placeholder)
   with Invalid_argument _ -> ()
  );

  (* The original directory entry has now been loaded, so
   * update its state.
   *)
  let state, content = get_hdata t row in
  let hdata = IsNode, content in
  store_hdata t row hdata