2 * Copyright (C) 2010 Red Hat Inc.
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.
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.
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.
32 type t = Filetree_type.t
34 let rec create ~packing () =
35 let view = GTree.view ~packing () in
36 (*view#set_rules_hint true;*)
37 (*view#selection#set_mode `MULTIPLE; -- add this later *)
39 (* Hash of index numbers -> hdata. We do this because it's more
40 * efficient for the GC compared to storing OCaml objects directly in
43 let hash = Hashtbl.create 1023 in
45 (* The columns stored in each row. The hidden [index_col] column is
46 * an index into the hash table that records everything else about
47 * this row (see hdata above). The other display columns, eg.
48 * [name_col] contain Pango markup and thus have to be escaped.
50 let cols = new GTree.column_list in
52 let index_col = cols#add Gobject.Data.int in
54 let mode_col = cols#add Gobject.Data.string in
55 let name_col = cols#add Gobject.Data.string in
56 let size_col = cols#add Gobject.Data.string in
57 let date_col = cols#add Gobject.Data.string in
59 (* Create the model. *)
60 let model = GTree.tree_store cols in
62 (* Create the view. *)
63 view#set_model (Some (model :> GTree.model));
65 let renderer = GTree.cell_renderer_text [], ["markup", mode_col] in
66 let mode_view = GTree.view_column ~title:"Permissions" ~renderer () in
67 mode_view#set_resizable true;
68 ignore (view#append_column mode_view);
70 let renderer = GTree.cell_renderer_text [], ["markup", name_col] in
71 let name_view = GTree.view_column ~title:"Filename" ~renderer () in
72 name_view#set_resizable true;
73 ignore (view#append_column name_view);
75 let renderer = GTree.cell_renderer_text [`XALIGN 1.], ["markup", size_col] in
76 let size_view = GTree.view_column ~title:"Size" ~renderer () in
77 size_view#set_resizable true;
78 ignore (view#append_column size_view);
80 let renderer = GTree.cell_renderer_text [`XALIGN 1.], ["markup", date_col] in
81 let date_view = GTree.view_column ~title:"Date" ~renderer () in
82 date_view#set_resizable true;
83 ignore (view#append_column date_view);
86 view = view; model = model; hash = hash;
87 index_col = index_col;
88 mode_col = mode_col; name_col = name_col; size_col = size_col;
92 (* Open a context menu when a button is pressed. *)
93 ignore (view#event#connect#button_press ~callback:(button_press t));
97 (* Handle mouse button press on the selected row. This opens the
98 * pop-up context menu.
99 * http://scentric.net/tutorial/sec-selections-context-menus.html
101 and button_press ({ model = model; view = view } as t) ev =
102 let button = GdkEvent.Button.button ev in
103 let x = int_of_float (GdkEvent.Button.x ev) in
104 let y = int_of_float (GdkEvent.Button.y ev) in
105 let time = GdkEvent.Button.time ev in
107 (* Right button for opening the context menu. *)
110 (* If no row is selected, select the row under the mouse. *)
112 let sel = view#selection in
113 if sel#count_selected_rows < 1 then (
114 match view#get_path_at_pos ~x ~y with
116 | Some (path, _, _, _) ->
118 sel#select_path path;
121 sel#get_selected_rows (* actually returns paths *) in
123 (* Select the row under the mouse. *)
125 let sel = view#selection in
126 match view#get_path_at_pos ~x ~y with
128 | Some (path, _, _, _) ->
130 sel#select_path path;
133 (* Get the hdata for all the paths. Filter out rows that it doesn't
134 * make sense to select.
139 let row = model#get_iter path in
140 let hdata = get_hdata t row in
142 | { content=(Loading | ErrorMessage _ | Info _) } -> None
143 | { content=(Top _ | Directory _ | File _) } -> Some (path, hdata)
146 (* Based on number of selected rows and what is selected, construct
149 if paths <> [] then (
150 let menu = make_context_menu t paths in
151 menu#popup ~button ~time
154 (* Return true so no other handler will run. *)
157 (* We didn't handle this, defer to other handlers. *)
160 and make_context_menu t paths =
161 let menu = GMenu.menu () in
162 let factory = new GMenu.factory menu in
164 let item = factory#add_item "Open" in
165 item#misc#set_sensitive false;
167 let rec add_file_items path =
168 let item = factory#add_item "File information" in
169 item#misc#set_sensitive false;
170 let item = factory#add_item "Checksum" in
171 item#misc#set_sensitive false;
172 ignore (factory#add_separator ());
173 let item = factory#add_item "Download ..." in
174 ignore (item#connect#activate ~callback:(download_file t path));
176 and add_directory_items path =
177 let item = factory#add_item "Directory information" in
178 item#misc#set_sensitive false;
179 let item = factory#add_item "Calculate disk usage" in
180 ignore (item#connect#activate ~callback:(disk_usage t path));
181 ignore (factory#add_separator ());
182 let item = factory#add_item "Download ..." in
183 item#misc#set_sensitive false;
184 let item = factory#add_item "Download as .tar ..." in
185 ignore (item#connect#activate
186 ~callback:(download_dir_tarball t Slave.Tar path));
187 let item = factory#add_item "Download as .tar.gz ..." in
188 ignore (item#connect#activate
189 ~callback:(download_dir_tarball t Slave.TGZ path));
190 let item = factory#add_item "Download as .tar.xz ..." in
191 ignore (item#connect#activate
192 ~callback:(download_dir_tarball t Slave.TXZ path));
193 let item = factory#add_item "Download list of filenames ..." in
194 ignore (item#connect#activate ~callback:(download_dir_find0 t path));
196 and add_os_items path =
197 let item = factory#add_item "Operating system information" in
198 ignore (item#connect#activate ~callback:(display_inspection_data t path));
199 ignore (factory#add_separator ());
200 add_volume_items path
202 and add_volume_items path =
203 let item = factory#add_item "Filesystem used & free" in
204 item#misc#set_sensitive false;
205 let item = factory#add_item "Block device information" in
206 item#misc#set_sensitive false;
207 ignore (factory#add_separator ());
208 add_directory_items path
212 (* single selection *)
213 | [path, { content=Top (Slave.OS os)} ] -> (* top level operating system *)
216 | [path, { content=Top (Slave.Volume dev) }] -> (* top level volume *)
217 add_volume_items path
219 | [path, { content=Directory direntry }] -> (* directory *)
220 add_directory_items path
222 | [path, { content=File direntry }] -> (* file *)
225 | [_, { content=Loading }]
226 | [_, { content=ErrorMessage _ }] -> ()
229 (* At the moment multiple selection is disabled. When/if we
230 * enable it we should do something intelligent here. XXX
238 let markup_of_mode mode =
240 if is_socket mode then 's'
241 else if is_symlink mode then 'l'
242 else if is_regular_file mode then '-'
243 else if is_block mode then 'b'
244 else if is_directory mode then 'd'
245 else if is_char mode then 'c'
246 else if is_fifo mode then 'p' else '?' in
247 let ru = if is_ru mode then 'r' else '-' in
248 let wu = if is_wu mode then 'w' else '-' in
249 let xu = if is_xu mode then 'x' else '-' in
250 let rg = if is_rg mode then 'r' else '-' in
251 let wg = if is_wg mode then 'w' else '-' in
252 let xg = if is_xg mode then 'x' else '-' in
253 let ro = if is_ro mode then 'r' else '-' in
254 let wo = if is_wo mode then 'w' else '-' in
255 let xo = if is_xo mode then 'x' else '-' in
256 let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in
258 let suid = is_suid mode in
259 let sgid = is_sgid mode in
260 let svtx = is_svtx mode in
261 if suid then str.[3] <- 's';
262 if sgid then str.[6] <- 's';
263 if svtx then str.[9] <- 't';
265 "<span color=\"#222222\" size=\"small\">" ^ str ^ "</span>"
268 let markup_of_date t =
269 (* Guestfs gives us int64's, we want float which is OCaml's
270 * equivalent of time_t.
272 let t = Int64.to_float t in
274 let show_full_date () =
275 let tm = localtime t in
276 sprintf "<span color=\"#222222\" size=\"small\">%04d-%02d-%02d %02d:%02d:%02d</span>"
277 (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
278 tm.tm_hour tm.tm_min tm.tm_sec
283 let ago = now -. t in
284 if ago < 0. then (* future *)
286 else if ago < 60. then
288 else if ago < 60. *. 60. then
289 sprintf "<small>%.0f minutes ago</small>" (ago /. 60.)
290 else if ago < 60. *. 60. *. 24. then
291 sprintf "<small>%.0f hours ago</small>" (ago /. 60. /. 60.)
292 else if ago < 60. *. 60. *. 24. *. 28. then
293 sprintf "<small>%.0f days ago</small>" (ago /. 60. /. 60. /. 24.)
297 (* Mark up file sizes. *)
298 let markup_of_size bytes =
299 sprintf "<small>%s</small>" (human_size bytes)
301 let clear { model = model; hash = hash } =
305 let rec add ({ model = model; hash = hash } as t) name data =
308 (* Populate the top level of the filetree. If there are operating
309 * systems from inspection, these have their own top level entries
310 * followed by only unreferenced filesystems. If we didn't get
311 * anything from inspection, then at the top level we just show
314 let other_filesystems =
315 DeviceSet.of_list (List.map fst data.Slave.insp_all_filesystems) in
316 let other_filesystems =
317 List.fold_left (fun set { Slave.insp_filesystems = fses } ->
318 DeviceSet.subtract set (DeviceSet.of_array fses))
319 other_filesystems data.Slave.insp_oses in
321 (* Add top level operating systems. *)
322 List.iter (add_top_level_os t name) data.Slave.insp_oses;
324 (* Add top level left-over filesystems. *)
325 DeviceSet.iter (add_top_level_vol t name) other_filesystems;
327 (* Expand the first top level node. *)
328 match model#get_iter_first with
331 t.view#expand_row (model#get_path row)
333 and add_top_level_os ({ model = model; hash = hash } as t) name os =
335 sprintf "<b>%s</b>\n<small>%s</small>\n<small>%s</small>"
336 (markup_escape name) (markup_escape os.Slave.insp_hostname)
337 (markup_escape os.Slave.insp_product_name) in
339 let row = model#append () in
340 make_node t row (Top (Slave.OS os));
341 model#set ~row ~column:t.name_col markup
343 and add_top_level_vol ({ model = model; hash = hash } as t) name dev =
345 sprintf "<b>%s</b>\n<small>from %s</small>"
346 (markup_escape dev) (markup_escape name) in
348 let row = model#append () in
349 make_node t row (Top (Slave.Volume dev));
350 model#set ~row ~column:t.name_col markup
352 (* Generic function to make an openable node to the tree. *)
353 and make_node ({ model = model; hash = hash } as t) row content =
354 let hdata = { state=NodeNotStarted; content=content; visited=false } in
355 store_hdata t row hdata;
357 (* Create a placeholder "loading ..." row underneath this node so
358 * the user has something to expand.
360 let placeholder = model#append ~parent:row () in
361 let hdata = { state=IsLeaf; content=Loading; visited=false } in
362 store_hdata t placeholder hdata;
363 model#set ~row:placeholder ~column:t.name_col "<i>Loading ...</i>";
364 ignore (t.view#connect#row_expanded ~callback:(expand_row t))
366 and make_leaf ({ model = model; hash = hash } as t) row content =
367 let hdata = { state=IsLeaf; content=content; visited=false } in
368 store_hdata t row hdata
370 (* This is called when the user expands a row. *)
371 and expand_row ({ model = model; hash = hash } as t) row _ =
372 match get_hdata t row with
373 | { state=NodeNotStarted; content=Top src } as hdata ->
374 (* User has opened a top level node that was not previously opened. *)
376 (* Mark this row as loading, so we don't try to open it again. *)
377 hdata.state <- NodeLoading;
379 (* Get a stable path for this row. *)
380 let path = model#get_path row in
382 Slave.read_directory ~fail:(when_read_directory_fail t path)
383 src "/" (when_read_directory t path)
385 | { state=NodeNotStarted; content=Directory direntry } as hdata ->
386 (* User has opened a filesystem directory not previously opened. *)
388 (* Mark this row as loading. *)
389 hdata.state <- NodeLoading;
391 (* Get a stable path for this row. *)
392 let path = model#get_path row in
394 let src, pathname = get_pathname t row in
396 Slave.read_directory ~fail:(when_read_directory_fail t path)
397 src pathname (when_read_directory t path)
399 | { state=(NodeLoading|IsNode) } -> ()
401 (* These are not nodes so it should never be possible to open them. *)
402 | { content=File _ } | { state=IsLeaf } -> assert false
404 (* Node should not exist in the tree. *)
405 | { state=NodeNotStarted; content=(Loading | ErrorMessage _ | Info _) } ->
408 (* This is the callback when the slave has read the directory for us. *)
409 and when_read_directory ({ model = model } as t) path entries =
410 debug "when_read_directory";
412 let row = model#get_iter path in
414 (* Add the entries. *)
417 let { Slave.dent_name = name; dent_stat = stat; dent_link = link } =
419 let row = model#append ~parent:row () in
420 if is_directory stat.G.mode then
421 make_node t row (Directory direntry)
423 make_leaf t row (File direntry);
424 model#set ~row ~column:t.name_col (markup_of_name direntry);
425 model#set ~row ~column:t.mode_col (markup_of_mode stat.G.mode);
426 model#set ~row ~column:t.size_col (markup_of_size stat.G.size);
427 model#set ~row ~column:t.date_col (markup_of_date stat.G.mtime);
430 (* Remove the placeholder "Loading" entry. NB. Must be done AFTER
431 * adding the other entries, or else Gtk will unexpand the row.
434 let row = find_child_node_by_content t row Loading in
435 ignore (model#remove row)
436 with Invalid_argument _ | Not_found -> ()
439 (* The original directory entry has now been loaded, so
442 let hdata = get_hdata t row in
443 hdata.state <- IsNode;
446 (* This is called instead of when_read_directory when the read directory
447 * (or mount etc) failed. Convert the "Loading" entry into the
450 and when_read_directory_fail ({ model = model } as t) path exn =
451 debug "when_read_directory_fail: %s" (Printexc.to_string exn);
455 let row = model#get_iter path in
456 let row = model#iter_children ~nth:0 (Some row) in
458 let hdata = { state=IsLeaf; content=ErrorMessage msg; visited=false } in
459 store_hdata t row hdata;
461 model#set ~row ~column:t.name_col (markup_escape msg)
464 (* unexpected exception: re-raise it *)