* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
-open ExtList
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.
- * We are going to store these in the model as simple ints because that
- * is easier on the GC. Don't change these numbers!
+ * 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).
*)
-let isFile = 0 (* it's not a directory, there are no children *)
-let dirNotStarted = 1 (* user has not tried to open this *)
-let dirLoading = 2 (* user tried to open it, still loading *)
-let isDir = 3 (* we've loaded the children of this directory *)
-let loading = 4 (* this row contains the "Loading ..." message *)
-
-let rec filetree dev rw =
- let view = GTree.view () in
+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 -> other data. We do this because it's
- * more efficient for the GC compared to storing OCaml objects
- * directly in the rows.
+ (* 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 [state_col] column
- * stores the current state of the row, and is used to implement
- * on-demand loading. The hidden [index_col] column is an index into
- * the hash table that records everything else about this row
- * (filename, file stat, etc). The other display columns, eg.
+ (* 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 state_col = cols#add Gobject.Data.int in
let index_col = cols#add Gobject.Data.int in
(* Displayed: *)
let mode_col = cols#add Gobject.Data.string 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", 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 link_view = GTree.view_column ~title:"Link" ~renderer () in
ignore (view#append_column link_view);
- let tree =
- model, view, hash, dev, rw,
- (state_col, index_col, mode_col, name_col, size_col, date_col,
- link_col) in
-
- (* Create the root directory entry, then expand it which will force
- * it to be loaded (asynchronously).
- * XXX Should stat "/"
- *)
- let root = model#append () in
- add_directory_row tree root "/" None;
- view#expand_row (model#get_path root);
-
- ignore (view#event#connect#button_press ~callback:(button_press tree));
- (*ignore (view#event#connect#popup_menu ~callback);*)
-
- view
-
-(* Add an "embryonic" directory to the tree store. This contains a
- * dummy entry (as explained
- * http://mail.gnome.org/archives/gtk-app-devel-list/2003-May/msg00241.html)
- * and when the user opens it, it triggers the real directory to be
- * read.
- *)
-and add_directory_row tree row filename direntry =
- let model, view, hash, _, _,
- (state_col, index_col, mode_col, name_col, size_col, date_col,
- link_col)
- = tree in
-
- model#set ~row ~column:state_col dirNotStarted;
- model#set ~row ~column:index_col (-1);
- model#set ~row ~column:name_col (markup_of_name filename);
- (match direntry with
- | None -> ()
- | Some direntry ->
- let index = unique () in
- Hashtbl.add hash index direntry;
- model#set ~row ~column:index_col index;
- let stat = direntry.Slave.dent_stat in
- model#set ~row ~column:mode_col (markup_of_mode stat.G.mode);
- model#set ~row ~column:size_col stat.G.size;
- model#set ~row ~column:date_col (markup_of_date stat.G.mtime));
-
- let placeholder = model#append ~parent:row () in
- model#set ~row:placeholder ~column:state_col loading;
- model#set ~row:placeholder ~column:index_col (-1);
- model#set ~row:placeholder ~column:name_col "<i>Loading ...</i>";
- ignore (view#connect#row_expanded ~callback:(expand_row tree))
-
-(* This is called when the user expands the [directory] row. *)
-and expand_row tree row _ =
- let model, _, _, dev, _, (state_col, _, _, _, _, _, _) = tree in
-
- match model#get ~row ~column:state_col with
- | 1 (* dirNotStarted *) -> (* Kick off a directory read. *)
- (* Get a stable path for this row so we can use it inside
- * the callback, which may happen a lot later.
- *)
- let path = model#get_path row in
-
- (* Now invoke libguestfs in the slave thread. *)
- Slave.read_directory
- dev (get_pathname tree row) (read_directory_cb tree path);
-
- (* Mark this row as now loading, so we don't start another
- * directory read if the user expands it again.
- *)
- model#set ~row ~column:state_col dirLoading
-
- | 0 (* isFile *) | 2 (* dirLoading *) | 3 (* isDir *) -> ()
- | 4 (* loading *) -> assert false
- | _ -> assert false
-
-and read_directory_cb tree path entries =
- let model, _, hash, _, _,
- (state_col, index_col, mode_col, name_col, size_col, date_col,
- link_col)
- = tree in
-
- 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
- add_directory_row tree row name (Some direntry)
- else (
- let index = unique () in
- Hashtbl.add hash index direntry;
- model#set ~row ~column:state_col isFile;
- model#set ~row ~column:index_col index;
- model#set ~row ~column:name_col (markup_of_name name);
- model#set ~row ~column:mode_col (markup_of_mode stat.G.mode);
- model#set ~row ~column:size_col stat.G.size;
- model#set ~row ~column:date_col (markup_of_date stat.G.mtime);
- model#set ~row ~column: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 _ -> ());
+ { 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 }
- (* The original directory entry has now been loaded, so
- * update its state.
- *)
- model#set ~row ~column:state_col isDir
-
-(* Get the actual full pathname of a row. *)
-and get_pathname tree row =
- let model, _, _, _, _, _ = tree in
-
- match model#iter_parent row with
- | None -> "/"
- | Some parent ->
- match get_direntry_of_row tree row with
- | Some { Slave.dent_name = name } ->
- let pname = get_pathname tree parent in
- if pname = "/" then "/" ^ name else pname ^ "/" ^ name
- | None ->
- assert false
-
-(* Get the directory entry from a row (contains the stat(2) results etc).
- * Some rows don't have the required information (eg. placeholder rows
- * and currently the root directory) and for them we return [None].
- *)
-and get_direntry_of_row tree row =
- let model, _, hash, _, _, (_, index_col, _, _, _, _, _) = tree in
- let index = model#get ~row ~column:index_col in
- try Some (Hashtbl.find hash index)
- with Not_found -> None
+let clear { model = model; hash = hash } =
+ model#clear ();
+ Hashtbl.clear hash
(* XXX No binding for g_markup_escape in lablgtk2. *)
-and markup_escape name =
+let markup_escape name =
let f = function
| '&' -> "&" | '<' -> "<" | '>' -> ">"
| c -> String.make 1 c
String.replace_chars f name
(* Mark up a filename for the name_col column. *)
-and markup_of_name name =
- (* First, protect against any markup in the name. *)
- let name = markup_escape name in
- name
+let rec markup_of_name name =
+ markup_escape name
(* Mark up symbolic links. *)
and markup_of_link link =
(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
-(* Handle mouse button press on the selected row. This opens the
- * pop-up context menu.
- * http://scentric.net/tutorial/sec-selections-context-menus.html
- *)
-and button_press tree ev =
- let button = GdkEvent.Button.button ev in
- let x = int_of_float (GdkEvent.Button.x ev) in
- let y = int_of_float (GdkEvent.Button.y ev) in
- let time = GdkEvent.Button.time ev in
-
- (* Right button for opening the context menu. *)
- if button = 3 then (
- let model, view, hash, _, _, (_, index_col, _, _, _, _, _) = tree in
-
- (* If no row is selected, select the row under the mouse. *)
- let paths =
- let sel = view#selection in
- if sel#count_selected_rows < 1 then (
- match view#get_path_at_pos ~x ~y with
- | None -> []
- | Some (path, _, _, _) ->
- sel#unselect_all ();
- sel#select_path path;
- [path]
- ) else
- sel#get_selected_rows (* actually returns paths *) in
-
- (* Ignore paths that don't contain index fields, and get the
- * direntry for the others. Currently this causes the root
- * directory to be ignored because we don't have stat information
- * for it (XXX).
- *)
- let paths =
- List.filter_map (
- fun path ->
- let row = model#get_iter path in
- match get_direntry_of_row tree row with
- | None -> None
- | Some direntry -> Some (path, direntry)
- ) paths in
-
- (* Choose the menu and menu options according to the number of
- * selected rows and what is selected.
- *)
- let menu =
- try
- (match paths with
- | [] -> None
- | [path, direntry] -> (* Single selection. *)
- (* What object is selected? *)
- let stat = direntry.Slave.dent_stat in
- let mode = stat.G.mode in
- if is_directory mode then
- Some (make_context_menu tree ~dir:true ~file:false paths)
- else if is_regular_file mode then
- Some (make_context_menu tree ~dir:false ~file:true paths)
- else (* not directory, not regular file *)
- Some (make_context_menu tree ~dir:false ~file:false paths)
- | paths -> (* Multiple selection. *)
- let dir = List.for_all (
- fun (_, { Slave.dent_stat = stat }) ->
- is_directory stat.G.mode
- ) paths in
- let file = List.for_all (
- fun (_, { Slave.dent_stat = stat }) ->
- is_regular_file stat.G.mode
- ) paths in
- Some (make_context_menu tree ~dir ~file paths)
- )
- with Not_found -> None
- in
- (match menu with
- | None -> ()
- | Some menu ->
- menu#popup ~button ~time;
- );
-
- (* Return true so no other handler will run. *)
- true
- ) else
- (* Defer to other handlers. *)
- false
-
-(* Make a context menu for file(s) and directory(s). ~file is true is
- * they are all regular files, ~dir is true if they are all
- * directories. If neither is set, then it can be a single selection
- * of a non-file non-directory, or it can be a mixed multiple
- * selection.
- *)
-and make_context_menu tree ~dir ~file paths =
- let _, _, _, _, rw, _ = tree in
- let n = List.length paths in
- assert (n > 0); (* calling code ensures this *)
- let path0 = List.hd paths in
-
- let menu = GMenu.menu () in
- let factory = new GMenu.factory menu in
-
- (* Open appears first, and unconditionally. This is just to catch
- * the case where nothing below matches, and we want to display
- * _something_. Open is not necessarily useful ...
+(* 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.
*)
- ignore (factory#add_item "Open");
- ignore (factory#add_separator ());
-
- if dir && n = 1 then (
- let item = factory#add_item "Disk _usage ..." in
- ignore (item#connect#activate ~callback:(disk_usage_dialog tree path0));
- let item = factory#add_item "_Export as an archive (tar etc) ..." in
- ignore (item#connect#activate ~callback:(export_archive_dialog tree path0));
- let item = factory#add_item "Export _checksums ..." in
- ignore (item#connect#activate
- ~callback:(export_checksums_dialog tree path0));
- let item = factory#add_item "Export as a _list of files ..." in
- ignore (item#connect#activate ~callback:(export_list_dialog tree path0));
- );
+ 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
- if file then
- ignore (factory#add_item "Determine file type ...");
+ Slave.read_directory src "/" (when_read_directory t path)
- if n = 1 then
- ignore (factory#add_item "View permissions ...");
+ | NodeNotStarted, Directory direntry ->
+ (* User has opened a filesystem directory not previously opened. *)
- (* Write operations go below the separator. *)
- (match rw with
- | Slave.RO -> ()
- | Slave.RW ->
- ignore (factory#add_separator ());
+ (* Mark this row as loading. *)
+ let hdata = NodeLoading, Directory direntry in
+ store_hdata t row hdata;
- if dir && n = 1 then (
- ignore (factory#add_item "New file ...");
- ignore (factory#add_item "New subdirectory ...");
- ignore (factory#add_item "Import an archive here ...");
- );
+ (* Get a stable path for this row. *)
+ let path = model#get_path row in
- if file then (
- ignore (factory#add_item "Touch file");
- ignore (factory#add_item "Edit file");
- );
+ let src, pathname = get_pathname t row in
- if n = 1 then
- ignore (factory#add_item "Edit permissions ...");
+ Slave.read_directory src pathname (when_read_directory t path)
- ignore (factory#add_item "Delete")
- );
+ | 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";
- menu
+ let row = model#get_iter path in
-(* The disk usage dialog. *)
-and disk_usage_dialog tree path0 () =
- let model, _, _, dev, _,_ = tree in
- let row = model#get_iter (fst path0) in
- let dir = get_pathname tree row 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;
- (* We can't use GWindow.message_dialog since lablgtk2 doesn't expose
- * the label field. It wouldn't help very much anyway.
+ (* Remove the placeholder entry. NB. Must be done AFTER adding
+ * the other entries, or else Gtk will unexpand the row.
*)
- let title = "Calculating disk usage ..." in
- let dlg = GWindow.dialog ~title ~modal:true () in
- let text =
- sprintf "Calculating disk usage of %s ... This may take a moment." dir in
- let label = GMisc.label ~text ~packing:dlg#vbox#pack () in
- dlg#add_button "Stop" `STOP;
- dlg#add_button "Close" `DELETE_EVENT;
- let close_button, stop_button =
- match dlg#action_area#children with
- | c::s::_ -> c, s
- | _ -> assert false in
- close_button#misc#set_sensitive false;
-
- let callback = function
- | `STOP -> debug "STOP response" (* XXX NOT IMPL XXX *)
- | `DELETE_EVENT -> debug "DELETE_EVENT response"; dlg#destroy ()
- in
- ignore (dlg#connect#response ~callback);
-
- Slave.disk_usage dev dir (
- fun kbytes -> (* Called when operation has finished. *)
- dlg#set_title "Disk usage";
- label#set_text (sprintf "Disk usage of %s: %Ld KB" dir kbytes);
- close_button#misc#set_sensitive true;
- stop_button#misc#set_sensitive false
+ (try
+ let placeholder = model#iter_children ~nth:0 (Some row) in
+ ignore (model#remove placeholder)
+ with Invalid_argument _ -> ()
);
- (* NB. We cannot use dlg#run. See:
- * http://www.math.nagoya-u.ac.jp/~garrigue/soft/olabl/lablgtk-list/600.txt
- * Therefore this function just exits back to the ordinary main loop.
+ (* The original directory entry has now been loaded, so
+ * update its state.
*)
- dlg#show ()
-
-and export_archive_dialog tree path0 () =
- (* XXX NOT IMPL XXX *)
-(* let model, _, _, dev, _,_ = tree in
- let row = model#get_iter (fst path0) in
- let dir = get_pathname tree row in*)
-
- let title = "Choose output file" in
- let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
-
- (* Allow the user to select the output format. *)
- let strings = ["tar.gz (compressed)"; "tar (uncompressed)"] in
- let combo, _ = GEdit.combo_box_text ~strings ~active:0 () in
- dlg#set_extra_widget (combo :> GObj.widget);
-
- dlg#show ()
-
-and export_checksums_dialog tree path0 () =
- (* XXX NOT IMPL XXX *)
-(* let model, _, _, dev, _,_ = tree in
- let row = model#get_iter (fst path0) in
- let dir = get_pathname tree row in*)
-
- let title = "Choose output file" in
- let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
-
- (* Allow the user to select the output algorithm. *)
- let strings =
- ["crc"; "md5"; "sha1"; "sha224"; "sha256"; "sha384"; "sha512"] in
- let combo, _ = GEdit.combo_box_text ~strings ~active:1 () in
- dlg#set_extra_widget (combo :> GObj.widget);
-
- dlg#show ()
-
-and export_list_dialog tree path0 () =
- (* XXX NOT IMPL XXX *)
-(* let model, _, _, dev, _,_ = tree in
- let row = model#get_iter (fst path0) in
- let dir = get_pathname tree row in*)
-
- let title = "Choose output file" in
- let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in
-
- (* Notify that the list of strings is \0 separated. *)
- let hbox =
- let hbox = GPack.hbox () in
- ignore (GMisc.image ~stock:`INFO ~packing:hbox#pack ());
- 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
- label#set_line_wrap true;
- hbox in
- dlg#set_extra_widget (hbox :> GObj.widget);
-
- dlg#show ()
-
-and do_export_dialog tree path0 t =
- (* XXX NOT IMPL XXX *)
- ()
+ let state, content = get_hdata t row in
+ let hdata = IsNode, content in
+ store_hdata t row hdata