*~
+*.cmi
+*.cmo
+*.cmx
+*.o
+.depend
+Makefile
+Makefile.in
+aclocal.m4
+autom4te.cache
+compile
+config.h
+config.h.in
+config.log
+config.ml
+config.status
+configure
+guestfs-browser
+install-sh
+missing
+stamp-h1
'slave.mli' (note lowercase first letter), and its implementation
in 'slave.ml'.
+In general terms, always start by reading the .mli file (if it exists)
+in order to understand the module and before opening the .ml file.
+
Threads and messages
--------------------
EXTRA_DIST = HACKING Throbber.png Throbber.gif
-CLEANFILES = *.cmi *.cmo *.cmx *.o guestfs-browser throbber.ml
+CLEANFILES = *.cmi *.cmo *.cmx *.o guestfs-browser
SOURCES = \
+ cmdline.mli \
+ cmdline.ml \
+ config.ml \
+ filetree.mli \
+ filetree.ml \
main.ml \
slave.mli \
slave.ml \
throbber.ml \
utils.mli \
- utils.ml
+ utils.ml \
+ window.mli \
+ window.ml
OBJECTS = \
- main.cmx \
- slave.cmx \
throbber.cmx \
- utils.cmx
+ config.cmx \
+ utils.cmx \
+ slave.cmx \
+ filetree.cmx \
+ cmdline.cmx \
+ window.cmx \
+ main.cmx
bin_SCRIPTS = guestfs-browser
-OCAMLOPTFLAGS = \
+OCAMLCFLAGS = \
+ -g \
-warn-error A \
-thread \
-package libvirt,guestfs,lablgtk2,extlib,xml-light,threads
+OCAMLOPTFLAGS = $(OCAMLCFLAGS)
+
guestfs-browser: $(OBJECTS)
- ocamlfind ocamlopt $(OCAMLOPTFLAGS) \
+ $(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) \
-predicates init,threads \
-linkpkg gtkThread.cmx \
$^ -o $@
+# This file is built. However gdk_pixbuf_mlsource requires X11 to
+# run, which prevents this from being built in places where an X
+# display is not available, such as on automated builders. So we'll
+# bundle this file in with the tarball anyway.
throbber.ml: Throbber.png Throbber.gif
- gdk_pixbuf_mlsource --build-list \
+ $(GDK_PIXBUF_MLSOURCE) --build-list \
static Throbber.png \
animation Throbber.gif \
> $@-t && mv $@-t $@
+
+.mli.cmi:
+ $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -c $< -o $@
+.ml.cmo:
+ $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -c $< -o $@
+.ml.cmx:
+ $(OCAMLFIND) ocamlopt $(OCAMLCFLAGS) -c $< -o $@
+
+depend: .depend
+
+.depend: $(wildcard *.mli) $(wildcard *.ml)
+ rm -f $@ $@-t
+ $(OCAMLFIND) ocamldep $^ > $@-t
+ mv $@-t $@
+
+include .depend
--- /dev/null
+>>> This is alpha quality software. Read 'HACKING' and 'TODO'. <<<
+
+Guest filesystem browser
+Copyright (C) 2010 Red Hat Inc.
+
+To compile from source, install the prerequisites (run the ./configure
+script and it will tell you what's missing).
+
+ autoreconf -i # if using the git version
+ ./configure
+ make
+
+We strongly suggest you run the program like this:
+
+ ./guestfs-browser [--verbose] [--write] --connect qemu:///system
+or:
+ ./guestfs-browser [--verbose] [--write] disk.img
+
+--verbose enables debug level messages and is recommended.
+
+--write enables writes to the filesystems and is *not* recommended.
+
+--connect tells the program which libvirt to connect to, and is
+required at the moment if you want to use libvirt, because we have not
+yet implemented the associated menu options.
--- /dev/null
+The context menu does nothing at the moment.
+
+The menu items do nothing at the moment.
--- /dev/null
+(* 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 Printf
+
+open Utils
+
+type cli_request =
+ | Connect_to_libvirt of string option
+ | Open_disk_image of string list
+ | Empty_window
+
+(* Parse command line arguments. *)
+let command_line () =
+ let connect_uri = ref None in
+ let images = ref [] in
+
+ let argspec = Arg.align [
+ "--verbose", Arg.Unit set_verbose_flag, " Enable debugging messages";
+ "--write", Arg.Unit set_write_flag, " Allow writes to the disk";
+ "--connect", Arg.String (function
+ | "" -> connect_uri := Some None
+ | uri -> connect_uri := Some (Some uri)),
+ "uri Connect to libvirt URI";
+ ] in
+
+ let anon_fun image = images := image :: !images in
+
+ let prog = Filename.basename Sys.executable_name in
+
+ let usage_msg =
+ sprintf "\
+
+%s: graphical guest filesystem browser
+
+Usage:
+ %s
+ Open the program with an empty window.
+
+ %s --connect ''
+ Connect to libvirt default URL to get list of guests.
+
+ %s --connect qemu:///system
+ Connect to some libvirt URL to get list of guests.
+ (Note only local libvirt connections are supported).
+
+ %s [--write] disk.img [disk.img [...]]
+ Start with a guest from a disk image file.
+
+Important note: The --write option must NEVER be used for live
+virtual machines. If you try to write to live VMs you will
+inevitably get disk corruption.
+
+Options:"
+ prog prog prog prog prog in
+
+ Arg.parse argspec anon_fun usage_msg;
+
+ let images = List.rev !images in
+ let connect_uri = !connect_uri in
+
+ match connect_uri, images with
+ | None, [] -> Empty_window
+ | None, images -> Open_disk_image images
+ | Some uri, [] -> Connect_to_libvirt uri
+ | Some uri, images ->
+ failwith "you cannot specify --connect and a list of disk images"
--- /dev/null
+(* 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.
+ *)
+
+(** Handle the command line arguments. *)
+
+type cli_request =
+ | Connect_to_libvirt of string option
+ | Open_disk_image of string list
+ | Empty_window
+ (** The initial action requested by the user on the command line.
+ For example if the command line contains --connect then
+ [Connect_to_libvirt] is returned by {!command_line}. *)
+
+val command_line : unit -> cli_request
+ (** Read the command line and return {!cli_request}. *)
--- /dev/null
+(* 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.
+ *)
+
+let package = "@PACKAGE_NAME@"
+let version = "@PACKAGE_VERSION@"
AC_MSG_ERROR([Please install OCaml module 'lablgtk2'.])
fi
+AC_CHECK_OCAML_PKG([libvirt])
+if test "$OCAML_PKG_libvirt" = "no"; then
+ AC_MSG_ERROR([Please install OCaml module 'libvirt'.])
+fi
+
+AC_CHECK_OCAML_PKG([guestfs])
+if test "$OCAML_PKG_guestfs" = "no"; then
+ AC_MSG_ERROR([Please install OCaml module 'guestfs'.])
+fi
+
+AC_CHECK_OCAML_PKG([xml-light])
+if test "$OCAML_PKG_xml_light" = "no"; then
+ AC_MSG_ERROR([Please install OCaml module 'xml-light'.])
+fi
+
+AC_CHECK_OCAML_PKG([extlib])
+if test "$OCAML_PKG_extlib" = "no"; then
+ AC_MSG_ERROR([Please install OCaml module 'extlib'.])
+fi
+
+dnl Check for gdk_pixbuf_mlsource program.
+AC_PATH_PROGS([GDK_PIXBUF_MLSOURCE], [gdk_pixbuf_mlsource])
+
AC_CONFIG_HEADERS([config.h])
-AC_CONFIG_FILES([Makefile])
+AC_CONFIG_FILES([Makefile config.ml])
AC_OUTPUT
--- /dev/null
+(* 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 ExtList
+open ExtString
+open Printf
+
+open Utils
+
+module G = Guestfs
+
+let unique = let i = ref 0 in fun () -> incr i; !i
+
+(* 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!
+ *)
+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
+ (*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.
+ *)
+ 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.
+ * [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 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
+
+ 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
+ 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);
+
+ 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 _ -> ());
+
+ (* 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
+
+(* XXX No binding for g_markup_escape in lablgtk2. *)
+and markup_escape name =
+ let f = function
+ | '&' -> "&" | '<' -> "<" | '>' -> ">"
+ | c -> String.make 1 c
+ in
+ 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
+
+(* 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
+
+(* 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
+
+ debug "make_context_menu dir %b file %b n %d" dir file n;
+
+ 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 ...
+ *)
+ ignore (factory#add_item "Open");
+ ignore (factory#add_separator ());
+
+ if dir && n = 1 then (
+ ignore (factory#add_item "Disk usage ...");
+ ignore (factory#add_item "Export as an archive (tar etc) ...");
+ ignore (factory#add_item "Export checksums ...");
+ ignore (factory#add_item "Export as a list of files ...");
+ );
+
+ if file then
+ ignore (factory#add_item "Determine file type ...");
+
+ if n = 1 then
+ ignore (factory#add_item "View permissions ...");
+
+ (* Write operations go below the separator. *)
+ (match rw with
+ | Slave.RO -> ()
+ | Slave.RW ->
+ ignore (factory#add_separator ());
+
+ 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 ...");
+ );
+
+ if file then (
+ ignore (factory#add_item "Touch file");
+ ignore (factory#add_item "Edit file");
+ );
+
+ if n = 1 then
+ ignore (factory#add_item "Edit permissions ...");
+
+ ignore (factory#add_item "Delete")
+ );
+
+ menu
--- /dev/null
+(* 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.
+ *)
+
+(** Tree model for displaying files in the guest filesystem.
+
+ The model reads files and directories on demand so that we don't
+ have to read the whole thing in at the beginning.
+
+ Originally this was written as a custom tree model, but we
+ couldn't get that to work. Instead we use something similar
+ to this trick:
+ http://mail.gnome.org/archives/gtk-app-devel-list/2003-May/msg00241.html *)
+
+val filetree : string -> Slave.rw_flag -> GTree.view
+ (** [filetree dev rw] creates a new filetree widget.
+
+ [dev] is the device.
+ [rw] is the RO|RW flag. *)
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
-open Utils
-
-(* Display state. *)
-type display_state = {
- window : GWindow.window;
- throbber_busy : unit -> unit;
- throbber_idle : unit -> unit;
-}
-
-let open_main_window () =
- let title = "Guest Filesystem Browser" in
- let window = GWindow.window ~width:800 ~height:600 ~title () in
- let vbox = GPack.vbox ~packing:window#add () in
-
- (* Do the menus. *)
- let menubar = GMenu.menu_bar ~packing:vbox#pack () in
- let factory = new GMenu.factory menubar in
- let accel_group = factory#accel_group in
- let connect_menu = factory#add_submenu "_Connect" in
-
- let factory = new GMenu.factory connect_menu ~accel_group in
- let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
+open Printf
- (* Quit. *)
- let quit _ = GMain.quit (); false in
- ignore (window#connect#destroy ~callback:GMain.quit);
- ignore (window#event#connect#delete ~callback:quit);
- ignore (quit_item#connect#activate
- ~callback:(fun () -> ignore (quit ()); ()));
-
- (* Top status area. *)
- let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in
- ignore (GMisc.label ~text:"Guest: " ~packing:hbox#pack ());
+open Utils
- (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *)
- let static = Throbber.static () in
- (*let animation = Throbber.animation () in*)
- let throbber =
- GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in
- let throbber_busy () =
- (*throbber#set_pixbuf animation*)
- (* Workaround because no binding for GdkPixbufAnimation: *)
- let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in
- throbber#set_file file
- and throbber_idle () =
- throbber#set_pixbuf static
- in
+module G = Guestfs
- window#show ();
- window#add_accel_group accel_group;
+(* Main. *)
+let () =
+ let cli_request = Cmdline.command_line () in
- (* display_state which is threaded through all the other callbacks,
- * allowing callbacks to update the window.
+ (* If we're in verbose mode, print some debug information which
+ * could be useful in bug reports.
*)
- { window = window;
- throbber_busy = throbber_busy; throbber_idle = throbber_idle }
-
-let () =
- let ds = open_main_window () in
- Slave.set_failure_hook (failure ds);
- Slave.set_busy_hook ds.throbber_busy;
- Slave.set_idle_hook ds.throbber_idle;
+ if verbose () then (
+ debug "%s %s" Config.package Config.version;
+ let v = fst (Libvirt.get_version ()) in
+ debug "libvirt %d.%d.%d"
+ (v / 1_000_000) ((v / 1_000) mod 1_000) (v mod 1_000);
+ let g = G.create () in
+ let v = G.version g in
+ debug "libguestfs %Ld.%Ld.%Ld%s"
+ v.G.major v.G.minor v.G.release v.G.extra;
+ G.close g;
+ );
+
+ let ds = Window.open_main_window () in
+ Slave.set_failure_hook (Window.failure ds);
+ Slave.set_busy_hook ds.Window.throbber_busy;
+ Slave.set_idle_hook ds.Window.throbber_idle;
+
+ (* What did the user request on the command line? *)
+ Window.run_cli_request ds cli_request;
(* Run the main display thread. When this returns, the application
* has been closed.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
+open ExtList
+open Printf
open Utils
module C = Libvirt.Connect
| Exit_thread
| Connect of string option * unit callback
| Get_domains of domain list callback
+ | Open_domain of string * rw_flag callback
+ | Open_images of string list * rw_flag callback
+ | Get_volumes of volume callback
+ | Read_directory of string * string * direntry list callback
and domain = {
dom_id : int;
dom_state : D.state;
}
+and rw_flag = RO | RW
+
+and volume = {
+ vol_device : string;
+ vol_type : string;
+ vol_label : string;
+ vol_uuid : string;
+ vol_statvfs : Guestfs.statvfs;
+}
+
+and direntry = {
+ dent_name : string;
+ dent_stat : Guestfs.stat;
+ dent_link : string;
+}
+
+let string_of_command = function
+ | Exit_thread -> "Exit_thread"
+ | Connect (Some name, _) -> sprintf "Connect %s" name
+ | Connect (None, _) -> "Connect NULL"
+ | Get_domains _ -> "Get_domains"
+ | Open_domain (name, _) -> sprintf "Open_domain %s" name
+ | Open_images (images, _) ->
+ sprintf "Open_images [%s]" (String.concat "; " images)
+ | Get_volumes _ -> "Get_volumes"
+ | Read_directory (dev, dir, _) -> sprintf "Read_directory %s %s" dev dir
+
+let string_of_rw_flag = function RO -> "RO" | RW -> "RW"
+
let no_callback _ = ()
let failure_hook = ref (fun _ -> ())
(* Send a command message to the slave thread. *)
let send_to_slave cmd =
- debug "sending message %s to slave thread ..." (string_of_command cmd)
+ debug "sending message %s to slave thread ..." (string_of_command cmd);
with_lock q_lock (
fun () ->
Q.push cmd q;
let connect uri cb = send_to_slave (Connect (uri, cb))
let get_domains cb = send_to_slave (Get_domains cb)
+let get_volumes cb = send_to_slave (Get_volumes cb)
+let open_domain name cb = send_to_slave (Open_domain (name, cb))
+let open_images images cb = send_to_slave (Open_images (images, cb))
+let read_directory dev dir cb = send_to_slave (Read_directory (dev, dir, cb))
(*----- Slave thread starts here -----*)
(* Set this to true to exit the thread. *)
let quit = ref false
+(* Handles. These are not protected by locks because only the slave
+ * thread has access to them.
+ *)
+let conn = ref None
+let g = ref None
+
+(* Call 'f ()' with 'dev' mounted read-only. Ensure that everything
+ * is unmounted even if an exception is thrown.
+ *)
+let with_mount_ro g dev (f : unit -> 'a) : 'a =
+ Std.finally (fun () -> G.umount_all g) (
+ fun () ->
+ G.mount_ro g dev "/";
+ f ()
+ ) ()
+
let rec loop () =
(* Get the next command. *)
let cmd =
Q.pop q
) in
- debug "slave thread processing command %s ..." (string_of_command cmd);
+ debug "thread id %d: slave processing command %s ..."
+ (Thread.id (Thread.self ())) (string_of_command cmd);
(try
- call_callback !busy_hook ();
+ GtkThread.async !busy_hook ();
execute_command cmd;
- call_callback !idle_hook ();
with exn ->
(* If a command fails, clear the command queue and run the
* failure hook in the main thread.
*)
- call_callback !idle_hook ();
discard_command_queue ();
- call_callback !failure_hook exn
+ GtkThread.async !failure_hook exn
);
+ (* If there are no more commands in the queue, run the idle hook. *)
+ let r = with_lock q_lock (fun () -> Q.is_empty q) in
+ if r then GtkThread.async !idle_hook ();
+
if !quit then Thread.exit ();
loop ()
and execute_command = function
| Exit_thread ->
quit := true;
- disconnect_all ()
+ close_all ()
- | Connect (uri, cb) ->
- disconnect_all ();
- conn := Some (C.connect_readonly ?uri ());
- call_callback cb ()
+ | Connect (name, cb) ->
+ close_all ();
+ conn := Some (C.connect_readonly ?name ());
+ GtkThread.async cb ()
| Get_domains cb ->
let conn = get_conn () in
let doms = D.get_domains conn [D.ListAll] in
let doms = List.map (
fun d ->
- D.get_id d, D.get_name d, (D.get_info d).D.state
+ { dom_id = D.get_id d;
+ dom_name = D.get_name d;
+ dom_state = (D.get_info d).D.state }
) doms in
- call_callback cb doms
+ let cmp { dom_name = n1 } { dom_name = n2 } = compare n1 n2 in
+ let doms = List.sort ~cmp doms in
+ GtkThread.async cb doms
+
+ | Open_domain (name, cb) ->
+ let conn = get_conn () in
+ let dom = D.lookup_by_name conn name in
+ (* Only permit writes to shut off domains. This isn't foolproof
+ * since the user could start up the domain while we're running,
+ * which would cause disk corruption. Until we can negotiate a
+ * feasible locking scheme with libvirt/qemu, this is the best we
+ * can do.
+ *)
+ let rw = write_flag () && (D.get_info dom).D.state = D.InfoShutoff in
+ let rw = if rw then RW else RO in
+ let xml = D.get_xml_desc dom in
+ let images = get_disk_images_from_xml xml in
+ open_disk_images rw images cb
+
+ | Open_images (images, cb) ->
+ let rw = write_flag () in
+ let rw = if rw then RW else RO in
+ open_disk_images rw images cb
-(* Call a callback function or hook in the main thread. *)
-and call_callback cb arg =
- GtkThread.async cb arg
+ | Get_volumes cb ->
+ let g = get_g () in
+ (* Devices which directly contain filesystems (RHBZ#590167). *)
+ let devices = G.list_devices g in
+ Array.iter (if_mountable_vol g cb) devices;
+ let partitions = G.list_partitions g in
+ Array.iter (if_mountable_vol g cb) partitions;
+ let lvs = G.lvs g in
+ Array.iter (if_mountable_vol g cb) lvs
+
+ | Read_directory (dev, dir, cb) ->
+ let g = get_g () in
+ let names, stats, links =
+ with_mount_ro g dev (
+ fun () ->
+ let names = G.ls g dir in (* sorted and without . and .. *)
+ let names = Array.to_list names in
+ let stats = lstatlist_wrapper g dir names in
+ let links = readlinklist_wrapper g dir names in
+ names, stats, links
+ ) in
+ assert (
+ let n = List.length names in
+ n = List.length stats && n = List.length links
+ );
+ let entries = List.combine (List.combine names stats) links in
+ let entries = List.map (
+ fun ((name, stat), link) ->
+ { dent_name = name; dent_stat = stat; dent_link = link }
+ ) entries in
+ GtkThread.async cb entries
(* Expect to be connected, and return the current libvirt connection. *)
-let get_conn () =
+and get_conn () =
match !conn with
| Some conn -> conn
| None -> failwith "not connected to libvirt"
+and get_g () =
+ match !g with
+ | Some g -> g
+ | None -> failwith "no domain or disk image is open"
+
(* Close all libvirt and libguestfs handles. *)
-and disconnect_all () =
+and close_all () =
(match !conn with Some conn -> C.close conn | None -> ());
- conn := None
+ conn := None;
+ close_g ()
+
+and close_g () =
+ (match !g with Some g -> G.close g | None -> ());
+ g := None
+
+and get_disk_images_from_xml xml =
+ let xml = Xml.parse_string xml in
+ let devices =
+ match xml with
+ | Xml.Element ("domain", _, children) ->
+ let devices =
+ List.filter_map (
+ function
+ | Xml.Element ("devices", _, devices) -> Some devices
+ | _ -> None
+ ) children in
+ List.concat devices
+ | _ ->
+ failwith "get_xml_desc didn't return <domain/>" in
+ let rec source_of = function (* <source file|dev=...> *)
+ | [] -> None
+ | Xml.Element ("source", attrs, _) :: rest ->
+ (try Some (List.assoc "dev" attrs)
+ with Not_found ->
+ try Some (List.assoc "file" attrs)
+ with Not_found ->
+ source_of rest)
+ | _ :: rest -> source_of rest
+ in
+ let blkdevs =
+ List.filter_map (
+ function
+ | Xml.Element ("disk", _, children) -> source_of children
+ | _ -> None
+ ) devices in
+ blkdevs
+
+(* The common code for Open_domain and Open_images which opens the
+ * libguestfs handle, adds the disks, and launches the appliance.
+ *)
+and open_disk_images rw images cb =
+ debug "opening disk image [%s] in %s mode"
+ (String.concat "; " images) (string_of_rw_flag rw);
+
+ close_g ();
+ let g' = G.create () in
+ g := Some g';
+ let g = g' in
+
+ G.set_verbose g (verbose ());
+
+ let add = (match rw with RO -> G.add_drive_ro | RW -> G.add_drive) g in
+ List.iter add images;
+
+ G.launch g;
+ GtkThread.async cb rw
+
+(* This is the common function implementing Get_volumes. Test if a
+ * particular partition contains a mountable filesystem. We do this
+ * simply by trying to mount it. If it does, get the rest of the
+ * information for the volume, and call the callback.
+ *)
+and if_mountable_vol g cb dev =
+ try
+ with_mount_ro g dev (
+ fun () ->
+ let vol_type = G.vfs_type g dev in
+ let vol_label = G.vfs_label g dev in
+ let vol_uuid = G.vfs_uuid g dev in
+ let vol_statvfs = G.statvfs g "/" in
+ let vol = {
+ vol_device = dev; vol_type = vol_type; vol_label = vol_label;
+ vol_uuid = vol_uuid; vol_statvfs = vol_statvfs
+ } in
+ GtkThread.async cb vol
+ )
+ with G.Error msg ->
+ debug "is_mountable: %s: not mountable because: %s" dev msg
+
+(* guestfs_lstatlist has a "hidden" limit of the protocol message size.
+ * Call this function, but split the list of names into chunks.
+ *)
+and lstatlist_wrapper g dir = function
+ | [] -> []
+ | names ->
+ let names', names = List.take 1000 names, List.drop 1000 names in
+ let xs = G.lstatlist g dir (Array.of_list names') in
+ let xs = Array.to_list xs in
+ xs @ lstatlist_wrapper g dir names
+
+(* Same as above for guestfs_readlinklist. *)
+and readlinklist_wrapper g dir = function
+ | [] -> []
+ | names ->
+ let names', names = List.take 1000 names, List.drop 1000 names in
+ let xs = G.readlinklist g dir (Array.of_list names') in
+ let xs = Array.to_list xs in
+ xs @ readlinklist_wrapper g dir names
(* Start up one slave thread. *)
let slave_thread = Thread.create loop ()
doesn't make sense to use remote URIs. *)
type domain = {
+ dom_id : int;
dom_name : string;
dom_state : Libvirt.Domain.state;
}
Note that [dom_state] is the state of the domain and should
control whether we are allowed to write to the domain's
- filesystem (disallowed if [dom_state] is [InfoRunning]). *)
+ filesystem (disallowed if [dom_state] is not [InfoShutoff]). *)
val get_domains : domain list callback -> unit
(** [get_domains cb] sends the [Get_domains] message to the
[cb] is called in the main thread with the list of
domains. See also the {!domain} type. *)
+type rw_flag = RO | RW
+ (** This flag is passed to open callbacks to indicate whether
+ we could open the disks read-only ([RO]) or read-write ([RW]). *)
+
+val open_domain : string -> rw_flag callback -> unit
+ (** [open_domain name cb] sends the [Open_domain] message to the
+ slave thread.
+
+ This causes the slave thread to retrieve the list of
+ block devices for the libvirt domain [name], create a
+ libguestfs handle, add those block devices, and launch
+ the handle. If this is successful, then [cb] is called
+ in the main thread.
+
+ If the domain is live then the disks are opened read only,
+ else they are opened read write if write_flag is true.
+ The [rw_flag] is passed into the callback accordingly.
+
+ The slave thread must be connected to libvirt (see {!connect})
+ else this command will fail. *)
+
+val open_images : string list -> rw_flag callback -> unit
+ (** [open_images images cb] is like {!open_domain} except
+ that it opens local disk image(s) directly. *)
+
+type volume = {
+ vol_device : string;
+ vol_type : string;
+ vol_label : string;
+ vol_uuid : string;
+ vol_statvfs : Guestfs.statvfs;
+}
+ (** The volume structure which is passed to the {!get_volumes} callback. *)
+
+val get_volumes : volume callback -> unit
+ (** [get_volumes cb] sends the [Get_volumes] message to the
+ slave thread.
+
+ This causes the slave thread to examine all partitions, LVs
+ etc within the current disk image, and for each that contains
+ a mountable filesystem, [cb] is called. (Note [cb] can be
+ called multiple times). *)
+
+type direntry = {
+ dent_name : string; (** Basename in directory. *)
+ dent_stat : Guestfs.stat; (** stat(2) for this entry. *)
+ dent_link : string; (** (for symlinks only) readlink(2). *)
+}
+
+val read_directory : string -> string -> direntry list callback -> unit
+ (** [read_directory dev dir cb] sends the [Read_directory] message
+ to the slave thread.
+
+ This causes the slave thread to read the contents of the
+ directory [dir] from volume [dev], and call [cb] with the
+ complete result. If [dir] is not a directory then this
+ is an error.
+
+ Note that [.] and [..] entries are not included in the result,
+ and the list is sorted on the [filename] field. *)
+
val discard_command_queue : unit -> unit
(** [discard_command_queue ()] discards any commands on the command
queue. The currently running command is not (and can not be)
--- /dev/null
+
+let static_data = "\
+\132\149\166\190\000\000\001\113\000\000\000\001\000\000\000\003\000\000\000\003\
+\018\071\100\107\080\105\120\098\117\102\047\050\046\048\047\000\000\000\001\093\
+\071\100\107\080\000\000\001\093\002\001\000\002\000\000\000\080\000\000\000\020\
+\000\000\000\020\157\000\000\000\000\130\178\178\178\255\145\000\000\000\000\132\
+\178\178\178\255\140\000\000\000\000\130\178\178\178\255\130\000\000\000\000\132\
+\178\178\178\255\130\000\000\000\000\130\178\178\178\255\135\000\000\000\000\132\
+\178\178\178\255\130\000\000\000\000\130\178\178\178\255\130\000\000\000\000\132\
+\178\178\178\255\134\000\000\000\000\132\178\178\178\255\134\000\000\000\000\132\
+\178\178\178\255\135\000\000\000\000\130\178\178\178\255\136\000\000\000\000\130\
+\178\178\178\255\154\000\000\000\000\130\178\178\178\255\140\000\000\000\000\130\
+\178\178\178\255\131\000\000\000\000\132\178\178\178\255\138\000\000\000\000\132\
+\178\178\178\255\130\000\000\000\000\132\178\178\178\255\138\000\000\000\000\132\
+\178\178\178\255\131\000\000\000\000\130\178\178\178\255\140\000\000\000\000\130\
+\178\178\178\255\154\000\000\000\000\130\178\178\178\255\136\000\000\000\000\130\
+\178\178\178\255\135\000\000\000\000\132\178\178\178\255\134\000\000\000\000\132\
+\178\178\178\255\134\000\000\000\000\132\178\178\178\255\130\000\000\000\000\130\
+\178\178\178\255\130\000\000\000\000\132\178\178\178\255\135\000\000\000\000\130\
+\178\178\178\255\130\000\000\000\000\132\178\178\178\255\130\000\000\000\000\130\
+\178\178\178\255\140\000\000\000\000\132\178\178\178\255\145\000\000\000\000\130\
+\178\178\178\255\157\000\000\000\000"
+
+let static () : GdkPixbuf.pixbuf = Marshal.from_string static_data 0
+
+let animation_data = "\
+\132\149\166\190\000\000\001\113\000\000\000\001\000\000\000\003\000\000\000\003\
+\018\071\100\107\080\105\120\098\117\102\047\050\046\048\047\000\000\000\001\093\
+\071\100\107\080\000\000\001\093\002\001\000\002\000\000\000\080\000\000\000\020\
+\000\000\000\020\157\255\255\255\000\130\000\000\000\255\145\255\255\255\000\132\
+\000\000\000\255\140\255\255\255\000\130\026\026\026\255\130\255\255\255\000\132\
+\000\000\000\255\130\255\255\255\000\130\178\178\178\255\135\255\255\255\000\132\
+\026\026\026\255\130\255\255\255\000\130\000\000\000\255\130\255\255\255\000\132\
+\178\178\178\255\134\255\255\255\000\132\026\026\026\255\134\255\255\255\000\132\
+\178\178\178\255\135\255\255\255\000\130\026\026\026\255\136\255\255\255\000\130\
+\178\178\178\255\154\255\255\255\000\130\051\051\051\255\140\255\255\255\000\130\
+\153\153\153\255\131\255\255\255\000\132\051\051\051\255\138\255\255\255\000\132\
+\153\153\153\255\130\255\255\255\000\132\051\051\051\255\138\255\255\255\000\132\
+\153\153\153\255\131\255\255\255\000\130\051\051\051\255\140\255\255\255\000\130\
+\153\153\153\255\154\255\255\255\000\130\076\076\076\255\136\255\255\255\000\130\
+\128\128\128\255\135\255\255\255\000\132\076\076\076\255\134\255\255\255\000\132\
+\128\128\128\255\134\255\255\255\000\132\076\076\076\255\130\255\255\255\000\130\
+\102\102\102\255\130\255\255\255\000\132\128\128\128\255\135\255\255\255\000\130\
+\076\076\076\255\130\255\255\255\000\132\102\102\102\255\130\255\255\255\000\130\
+\128\128\128\255\140\255\255\255\000\132\102\102\102\255\145\255\255\255\000\130\
+\102\102\102\255\157\255\255\255\000"
+
+let animation () : GdkPixbuf.pixbuf = Marshal.from_string animation_data 0
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
-type ('a, 'b) choice = Either of 'a | Or of 'b
+open Printf
-let verbose = ref true (* XXX settable *)
+let (+^) = Int64.add
+let (-^) = Int64.sub
+let ( *^ ) = Int64.mul
+let (/^) = Int64.div
+
+type ('a, 'b) either = Left of 'a | Right of 'b
+
+let verbose = ref false
+let set_verbose_flag () = verbose := true
+let verbose () = !verbose
+
+let write_flag = ref false
+let set_write_flag () = write_flag := true
+let write_flag () = !write_flag
let debug fs =
- let f str = if !verbose then (prerr_string str; prerr_newline ()) in
+ let f str =
+ if verbose () then (
+ prerr_string Config.package;
+ prerr_string ": ";
+ prerr_string str;
+ prerr_newline ()
+ )
+ in
ksprintf f fs
let failwith fs =
let f str =
- if !verbose then (prerr_string str; prerr_newline ());
+ if verbose () then (prerr_string str; prerr_newline ());
raise (Failure str)
in
ksprintf f fs
+
+let utf8_rarrow = "\xe2\x86\x92"
+
+let human_size_1k i =
+ if i < 1024L then
+ sprintf "%LdK" i
+ else if i < 1024L *^ 1024L then
+ sprintf "%.1fM" (Int64.to_float i /. 1024.)
+ else
+ sprintf "%.1fG" (Int64.to_float i /. 1024. /. 1024.)
(** General-purpose utility code used everywhere. *)
+val (+^) : int64 -> int64 -> int64
+val (-^) : int64 -> int64 -> int64
+val ( *^ ) : int64 -> int64 -> int64
+val (/^) : int64 -> int64 -> int64
+ (** Int64 arithmetic operators. *)
+
type ('a, 'b) either = Left of 'a | Right of 'b
(** A value which is either an ['a] or a ['b], just like Haskell's
"Either" type. *)
-val verbose : bool ref
+val verbose : unit -> bool
+val set_verbose_flag : unit -> unit
(** If this contains [true] then {!debug} will send debugging
- messages to stderr, else debugging messages are dropped. *)
+ messages to stderr, else debugging messages are dropped.
+
+ This is set through the --verbose command line option. *)
+
+val write_flag : unit -> bool
+val set_write_flag : unit -> unit
+ (** Writes are prevented unless the user sets this to [true]
+ through the command line option --write. *)
-val debug : ('a, out_channel, unit) format -> 'a
+val debug : ('a, unit, string, unit) format4 -> 'a
(** A printf-like function for writing debugging messages. *)
-val failwith : ('a, out_channel, unit) format -> 'a
+val failwith : ('a, unit, string, 'b) format4 -> 'a
(** Replacement for standard OCaml [failwith] function. This can
take a printf-like argument list, and also logs errors on stderr
when verbose is enabled. *)
+
+val utf8_rarrow : string (** UTF-8 RIGHTWARDS ARROW *)
+
+val human_size_1k : int64 -> string
+ (** Convert a number (of 1K blocks) into a human readable string. *)
--- /dev/null
+(* 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 Printf
+
+open Utils
+
+module G = Guestfs
+
+let (//) = Filename.concat
+
+(* Display state. *)
+type display_state = {
+ window : GWindow.window;
+ throbber_busy : unit -> unit;
+ throbber_idle : unit -> unit;
+ set_statusbar : string -> unit;
+ clear_statusbar : unit -> unit;
+ set_vmlist : string list -> unit;
+ clear_vmlist : unit -> unit;
+ clear_notebook : unit -> unit;
+ filesystem : GPack.box;
+ notebook : GPack.notebook;
+}
+
+let rec open_main_window () =
+ let title = "Guest Filesystem Browser" in
+ let window = GWindow.window ~width:800 ~height:600 ~title () in
+ let vbox = GPack.vbox ~packing:window#add () in
+
+ (* Do the menus. *)
+ let menubar = GMenu.menu_bar ~packing:vbox#pack () in
+ let factory = new GMenu.factory menubar in
+ let accel_group = factory#accel_group in
+ let connect_menu = factory#add_submenu "_Connect" in
+
+ let factory = new GMenu.factory connect_menu ~accel_group in
+ let connect_item = factory#add_item "_Connect to libvirt ..." in
+ let open_item = factory#add_item "_Open disk image ..." ~key:GdkKeysyms._O in
+ ignore (factory#add_separator ());
+ let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
+
+ (* Quit. *)
+ let quit _ = GMain.quit (); false in
+ ignore (window#connect#destroy ~callback:GMain.quit);
+ ignore (window#event#connect#delete ~callback:quit);
+ ignore (quit_item#connect#activate
+ ~callback:(fun () -> ignore (quit ()); ()));
+
+ (* Top status area. *)
+ let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in
+ hbox#pack (mklabel "Guest: ");
+
+ (* List of VMs. *)
+ let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in
+ let set_vmlist names =
+ let combo, (model, column) = vmcombo in
+ model#clear ();
+ List.iter (
+ fun name ->
+ let row = model#append () in
+ model#set ~row ~column name
+ ) names
+ in
+ let clear_vmlist () = set_vmlist [] in
+
+ (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *)
+ let static = Throbber.static () in
+ (*let animation = Throbber.animation () in*)
+ let throbber =
+ GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in
+ let throbber_busy () =
+ (*throbber#set_pixbuf animation*)
+ (* Workaround because no binding for GdkPixbufAnimation: *)
+ let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in
+ throbber#set_file file
+ and throbber_idle () =
+ throbber#set_pixbuf static
+ in
+
+ (* Tabbed pane ("notebook") filling the main window. *)
+ let nb = GPack.notebook ~scrollable:true
+ ~packing:(vbox#pack ~expand:true ~fill:true) () in
+ let filesystem = GPack.vbox () in
+ filesystem#add (intro_label () :> GObj.widget);
+ ignore (nb#append_page
+ ~tab_label:(mklabel "Filesystem") (filesystem :> GObj.widget));
+ let clear_notebook () =
+ nb#goto_page 0;
+ (* Remove all tabs except the first ("Filesystem") tab ... *)
+ List.iter nb#remove (List.tl nb#all_children);
+ (* ... and clear out the filesystem tab. *)
+ List.iter filesystem#remove filesystem#all_children
+ in
+
+ (* Status bar at the bottom of the screen. *)
+ let set_statusbar =
+ let statusbar = GMisc.statusbar ~packing:vbox#pack () in
+ let context = statusbar#new_context ~name:"Standard" in
+ ignore (context#push title);
+ fun msg ->
+ context#pop ();
+ ignore (context#push msg)
+ in
+ let clear_statusbar () = set_statusbar "" in
+
+ window#show ();
+ window#add_accel_group accel_group;
+
+ (* display_state which is threaded through all the other callbacks,
+ * allowing callbacks to update the window.
+ *)
+ let ds = {
+ window = window;
+ throbber_busy = throbber_busy; throbber_idle = throbber_idle;
+ set_statusbar = set_statusbar; clear_statusbar = clear_statusbar;
+ set_vmlist = set_vmlist; clear_vmlist = clear_vmlist;
+ clear_notebook = clear_notebook;
+ filesystem = filesystem; notebook = nb;
+ } in
+
+ (* Set up some callbacks which require access to the display_state. *)
+ ignore (
+ let combo, (model, column) = vmcombo in
+ combo#connect#changed
+ ~callback:(
+ fun () ->
+ match combo#active_iter with
+ | None -> ()
+ | Some row ->
+ let name = model#get ~row ~column in
+ ds.set_statusbar (sprintf "Opening %s ..." name);
+ ds.clear_notebook ();
+ Slave.open_domain name (opened_domain ds))
+ );
+
+ ignore (connect_item#connect#activate ~callback:(connect_dialog ds));
+ ignore (open_item#connect#activate ~callback:(open_dialog ds));
+
+ (* Return the display state. *)
+ ds
+
+(* Convenience function to make a label containing some text. It is
+ * returned as a generic widget.
+ *)
+and mklabel text =
+ (GMisc.label ~text () :> GObj.widget)
+
+(* This is called in the main thread whenever a command fails in the
+ * slave thread. The command queue has been cleared before this is
+ * called, so our job here is to reset the main window, and if
+ * necessary to turn the exception into an error message.
+ *)
+and failure ds exn =
+ let title = "Error" in
+ let msg = Printexc.to_string exn in
+ debug "thread id %d: failure hook: %s" (Thread.id (Thread.self ())) msg;
+ let icon = GMisc.image () in
+ icon#set_stock `DIALOG_ERROR;
+ icon#set_icon_size `DIALOG;
+ GToolbox.message_box ~title ~icon msg
+
+(* This is called in the main thread when we've connected to libvirt. *)
+and connected ds uri () =
+ debug "thread id %d: connected callback" (Thread.id (Thread.self ()));
+ let msg =
+ match uri with
+ | None -> "Connected to libvirt"
+ | Some uri -> sprintf "Connected to %s" uri in
+ ds.set_statusbar msg;
+ Slave.get_domains (got_domains ds)
+
+(* This is called in the main thread when we've got the list of domains. *)
+and got_domains ds doms =
+ let doms = List.map (fun { Slave.dom_name = name } -> name) doms in
+ debug "thread id %d: got_domains callback: (%s)"
+ (Thread.id (Thread.self ())) (String.concat " " doms);
+ ds.set_vmlist doms
+
+(* This callback indicates that the domain was opened successfully. *)
+and opened_domain ds rw =
+ debug "thread id %d: opened_domain callback" (Thread.id (Thread.self ()));
+ opened ds rw
+
+(* This callback indicates that local disk image(s) were opened successfully.*)
+and opened_images ds rw =
+ debug "thread id %d: opened_images callback" (Thread.id (Thread.self ()));
+ opened ds rw
+
+and opened ds rw =
+ ds.clear_statusbar ();
+ ds.clear_notebook ();
+
+ (* Get the list of mountable filesystems. *)
+ Slave.get_volumes (got_volume ds rw)
+
+(* This callback is called once for each mountable filesystem that is
+ * found in a guest.
+ *)
+and got_volume ds rw vol =
+ let dev = vol.Slave.vol_device in
+ debug "thread id %d: got_volume callback: %s"
+ (Thread.id (Thread.self ())) dev;
+
+ (* What's on the tab. *)
+ let tab =
+ match vol.Slave.vol_label with
+ | "" -> sprintf "%s" dev
+ | label -> sprintf "%s (%s)" dev label in
+
+ (* What's on the notebook page. *)
+ let page =
+ let vbox = GPack.vbox () in
+
+ (* VFS stats table. *)
+
+ (* For calculations, see libguestfs/tools/virt-df. *)
+ let st = vol.Slave.vol_statvfs in
+ let factor = st.G.bsize /^ 1024L in
+
+ (* Right-aligned label with width, for stats table. *)
+ let mklabelh text =
+ let markup = "<b>" ^ text ^ "</b>" in
+ let label = GMisc.label ~markup ~xalign:1. () in
+ label#set_width_chars 12;
+ (label :> GObj.widget)
+ and mklabelr text =
+ let label = GMisc.label ~text ~selectable:true ~xalign:1. () in
+ label#set_width_chars 12;
+ (label :> GObj.widget)
+ in
+
+ let stats = GPack.table ~columns:4 ~rows:5
+ ~homogeneous:true ~col_spacings:4 ~row_spacings:4
+ ~packing:vbox#pack () in
+ stats#attach ~top:0 ~left:0 (mklabelh "1K-blocks");
+ stats#attach ~top:0 ~left:1 (mklabelh "Used");
+ stats#attach ~top:0 ~left:2 (mklabelh "Available");
+ stats#attach ~top:0 ~left:3 (mklabelh "Use%");
+ let blocks = st.G.blocks *^ factor in
+ stats#attach ~top:1 ~left:0 (mklabelr (sprintf "%Ld" blocks));
+ let used = (st.G.blocks -^ st.G.bfree) *^ factor in
+ stats#attach ~top:1 ~left:1 (mklabelr (sprintf "%Ld" used));
+ let available = st.G.bavail *^ factor in
+ stats#attach ~top:1 ~left:2 (mklabelr (sprintf "%Ld" available));
+ stats#attach ~top:1 ~left:3
+ (mklabelr (sprintf "%Ld%%" (100L -^ 100L *^ st.G.bfree /^ st.G.blocks)));
+ stats#attach ~top:2 ~left:0 (mklabelr ("= " ^ human_size_1k blocks));
+ stats#attach ~top:2 ~left:1 (mklabelr ("= " ^ human_size_1k used));
+ stats#attach ~top:2 ~left:2 (mklabelr ("= " ^ human_size_1k available));
+ stats#attach ~top:3 ~left:0 (mklabelh "Inodes");
+ stats#attach ~top:3 ~left:1 (mklabelh "IUsed");
+ stats#attach ~top:3 ~left:2 (mklabelh "IFree");
+ stats#attach ~top:3 ~left:3 (mklabelh "IUse%");
+ stats#attach ~top:4 ~left:0 (mklabelr (sprintf "%Ld" st.G.files));
+ stats#attach ~top:4 ~left:1
+ (mklabelr (sprintf "%Ld" (st.G.files -^ st.G.ffree)));
+ stats#attach ~top:4 ~left:2 (mklabelr (sprintf "%Ld" st.G.ffree));
+ stats#attach ~top:4 ~left:3
+ (mklabelr (sprintf "%Ld%%" (100L -^ 100L *^ st.G.ffree /^ st.G.files)));
+
+ (* Info table. *)
+
+ (* Left- and right-aligned labels, for info table. *)
+ let mklabelr text =
+ let label = GMisc.label ~text ~xalign:1. () in
+ label#set_width_chars 9;
+ (label :> GObj.widget)
+ and mklabell text =
+ let label = GMisc.label ~text ~selectable:true ~xalign:0. () in
+ (label :> GObj.widget)
+ in
+
+ let info = GPack.table ~columns:4 ~rows:2
+ ~col_spacings:4 ~row_spacings:4
+ ~packing:vbox#pack () in
+ info#attach ~top:0 ~left:0 (mklabelr "FS label:");
+ info#attach ~top:0 ~left:1 (mklabell vol.Slave.vol_label);
+ info#attach ~top:1 ~left:0 (mklabelr "FS type:");
+ info#attach ~top:1 ~left:1 (mklabell vol.Slave.vol_type);
+ info#attach ~top:0 ~left:2 (mklabelr "FS UUID:");
+ info#attach ~top:0 ~left:3 (mklabell vol.Slave.vol_uuid);
+ info#attach ~top:1 ~left:2 (mklabelr "Device:");
+ info#attach ~top:1 ~left:3 (mklabell dev);
+
+ (* Files display. *)
+ let sw = GBin.scrolled_window
+ ~packing:(vbox#pack ~expand:true ~fill:true)
+ ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
+ let view = Filetree.filetree dev rw in
+ sw#add (view :> GObj.widget);
+
+ vbox in
+ ignore (
+ ds.notebook#append_page ~tab_label:(mklabel tab) (page :> GObj.widget)
+ )
+
+(* Open the connect to libvirt dialog. *)
+and connect_dialog ds () =
+ debug "connect menu";
+ (*ds.clear_notebook ();*)
+ failwith "XXX CONNECT DLG NOT IMPL"
+
+(* Open the disk images dialog. *)
+and open_dialog ds () =
+ debug "open menu";
+ (*ds.clear_notebook ();*)
+ failwith "XXX OPEN DLG NOT IMPL"
+
+(* The introductory text which appears in the tabbed notebook to
+ * tell the user how to start. XXX We should add images.
+ *)
+and intro_label () =
+ let text =
+ sprintf "Open a disk image (Connect %s Open disk image), connect to libvirt (Connect %s Connect to libvirt), or choose a guest from the \"Guest\" menu above."
+ utf8_rarrow utf8_rarrow in
+ let label = GMisc.label ~text () in
+ label#set_line_wrap true;
+ label
+
+let run_cli_request ds = function
+ | Cmdline.Empty_window -> ()
+ | Cmdline.Connect_to_libvirt uri ->
+ Slave.connect uri (connected ds uri)
+ | Cmdline.Open_disk_image images ->
+ Slave.open_images images (opened_images ds)
--- /dev/null
+(* 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.
+ *)
+
+(** The Window module handles all aspects of the main window, menus,
+ dialogs and so on. *)
+
+type display_state = {
+ window : GWindow.window;
+ throbber_busy : unit -> unit;
+ throbber_idle : unit -> unit;
+ set_statusbar : string -> unit;
+ clear_statusbar : unit -> unit;
+ set_vmlist : string list -> unit;
+ clear_vmlist : unit -> unit;
+ clear_notebook : unit -> unit;
+ filesystem : GPack.box;
+ notebook : GPack.notebook;
+}
+ (** This structure describes various variables and functions
+ for the main window. It is returned from {!open_main_window}
+ and passed around to various other functions. *)
+
+val open_main_window : unit -> display_state
+ (** Open the main Gtk window, set up the menus, callbacks and so on. *)
+
+val failure : display_state -> exn -> unit
+ (** This is the global error handling function. It is invoked in
+ the main thread for failures in the slave thread (see
+ {!Slave.set_failure_hook}). *)
+
+val run_cli_request : display_state -> Cmdline.cli_request -> unit
+ (** This function performs the {!Cmdline.cli_request} operation.
+ The actual operation happens asynchronously after this function
+ has returned. *)
git.annexia.org / guestfs-browser.git / commitdiff