modules, eg:
module C = Libvirt.Connect
- module G = Guestfs
+ module Q = Queue
So when you see a function such as 'C.connect_readonly', it's really
the function 'connect_readonly' in the [nested] module
CLEANFILES = *.cmi *.cmo *.cmx *.o guestfs-browser
+# These are listed here in alphabetical order.
SOURCES = \
- cmdline.mli \
- cmdline.ml \
config.mli \
config.ml \
+ deviceSet.mli \
+ deviceSet.ml \
filetree.mli \
filetree.ml \
main.ml \
window.mli \
window.ml
+# Note this list must be in dependency order.
OBJECTS = \
- throbber.cmx \
config.cmx \
+ throbber.cmx \
utils.cmx \
+ deviceSet.cmx \
slave.cmx \
filetree.cmx \
- cmdline.cmx \
window.cmx \
main.cmx
OCAMLPACKAGES = libvirt,guestfs,lablgtk2,extlib,xml-light,threads
OCAMLCFLAGS = \
-g \
- -warn-error A \
+ -warn-error CDEFLMPSUVYZX \
-thread \
-package $(OCAMLPACKAGES) \
-predicates threads
We strongly suggest you run the program like this:
- guestfs-browser [--verbose] [--write] --connect qemu:///system
+ guestfs-browser [--verbose] --connect qemu:///system
or:
- guestfs-browser [--verbose] [--write] disk.img
+ guestfs-browser [--verbose] disk.img
--verbose enables debug level messages and is recommended.
---write enables writes to the filesystems and is *not* recommended for
-casual users.
-
--connect tells the program which libvirt URI to connect to.
Note that libguestfs cannot access remote storage, so accessing a
+++ /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 canonical dev =
+ let len = String.length dev in
+ if len >= 8 &&
+ dev.[0] = '/' &&
+ dev.[1] = 'd' && dev.[2] = 'e' && dev.[3] = 'v' &&
+ dev.[4] = '/' &&
+ (dev.[5] = 'h' || dev.[5] = 's' || dev.[5] = 'v') &&
+ dev.[6] = 'd' &&
+ dev.[7] >= 'a' && dev.[7] <= 'z' then (
+ let dev = String.copy dev in
+ dev.[5] <- 's';
+ dev
+ )
+ else
+ dev
+
+let canonical_compare dev1 dev2 =
+ let dev1 = canonical dev1 in
+ let dev2 = canonical dev2 in
+ String.compare dev1 dev2
+
+module DeviceSet = struct
+ include Set.Make (
+ struct
+ type t = String.t
+ let compare = canonical_compare
+ end
+ )
+
+ let subtract = diff
+
+ let of_list ds =
+ List.fold_left (fun set d -> add (canonical d) set) empty ds
+
+ let of_array ds =
+ of_list (Array.to_list ds)
+
+ let to_string t =
+ "{" ^ String.concat " " (elements t) ^ "}"
+end
--- /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.
+ *)
+
+(** Set of devices.
+
+ This is essentially the same as a set of strings (see OCaml {!Set}
+ module), but we relax comparisons so that devices with the same
+ canonical name are the same. For example "/dev/sda5" is
+ considered the same as "/dev/vda5". *)
+
+module DeviceSet : sig
+ type t
+ (** The type of the set. *)
+
+ type elt = String.t
+ (** The type of each element of the set. *)
+
+ val subtract : t -> t -> t
+ (** Set difference.
+
+ [subtract a b] is like a subtraction operation, returning a
+ new set which is constructed by removing all elements of [b]
+ from [a].
+
+ (Note that this is the same operation as {!Set.diff}). *)
+
+ val iter : (elt -> unit) -> t -> unit
+ (** [iter f set] iterates over the set in increasing order. *)
+
+ val of_list : elt list -> t
+ (** Construct a new set from the list of elements. *)
+
+ val of_array : elt array -> t
+ (** Construct a new set from the array of elements. *)
+
+ val to_string : t -> string
+ (** Make the set into a printable string (just for debugging). *)
+end
* 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
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.
+type t
- [dev] is the device.
- [rw] is the RO|RW flag. *)
+val create : packing:(GObj.widget -> unit) -> unit -> t
+ (** Create a new filetree widget (empty). *)
+
+val clear : t -> unit
+ (** Clear out all rows in existing widget. *)
+
+val add : t -> string -> Slave.inspection_data -> unit
+ (** [add t name data] clears out the widget and adds the operating
+ system and/or filesystems described by the [data] struct. The
+ [name] parameter should be some host-side (verifiable) name;
+ usually we pass the name of the guest from libvirt here. *)
open Utils
-module G = Guestfs
-
(* Main. *)
let () =
- let cli_request = Cmdline.command_line () in
+ (* XXX command line *)
+ Utils.set_verbose_flag ();
(* If we're in verbose mode, print some debug information which
* could be useful in bug reports.
*)
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;
+ debug "libguestfs %s" (libguestfs_version_string ());
+ debug "libvirt %s" (libvirt_version_string ());
);
- 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;
+ let ws = Window.open_main_window () in
+ Slave.set_failure_hook (Window.failure ws);
+ Slave.set_busy_hook (Window.throbber_busy ws);
+ Slave.set_idle_hook (Window.throbber_idle ws);
(* What did the user request on the command line? *)
- Window.run_cli_request ds cli_request;
+ (*Window.run_cli_request ws cli_request;*)
(* Run the main display thread. When this returns, the application
* has been closed.
module C = Libvirt.Connect
module Cond = Condition
module D = Libvirt.Domain
-module G = Guestfs
module M = Mutex
module Q = Queue
(* The commands. *)
type command =
| 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
- | Disk_usage of string * string * int64 callback
- | Export_dir_to of export_t * string * string * string * unit callback
+ | Connect of string option * domain list callback
+ | Open_domain of string * inspection_data callback
+ | Open_images of string list * inspection_data callback
+ | Read_directory of source * string * direntry list callback
and domain = {
dom_id : int;
dom_state : D.state;
}
-and rw_flag = RO | RW
+and inspection_data = {
+ insp_all_filesystems : (string * string) list;
+ insp_oses : inspection_os list;
+}
-and volume = {
- vol_device : string;
- vol_type : string;
- vol_label : string;
- vol_uuid : string;
- vol_statvfs : Guestfs.statvfs;
+and inspection_os = {
+ insp_root : string;
+ insp_arch : string;
+ insp_distro : string;
+ insp_filesystems : string array;
+ insp_hostname : string;
+ insp_major_version : int;
+ insp_minor_version : int;
+ insp_mountpoints : (string * string) list;
+ insp_package_format : string;
+ insp_package_management : string;
+ insp_product_name : string;
+ insp_type : string;
+ insp_windows_systemroot : string option;
}
+and source = OS of inspection_os | Volume of string
+
and direntry = {
dent_name : string;
dent_stat : Guestfs.stat;
dent_link : string;
}
-and export_t =
- | Export_tar
- | Export_tgz
- | Export_checksums of string
- | Export_list
-
let rec 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
- | Disk_usage (dev, dir, _) -> sprintf "Disk_usage %s %s" dev dir
- | Export_dir_to (t, dev, dir, file, _) ->
- sprintf "Export_dir_to %s %s %s %s" (string_of_export_t t) dev dir file
-
-and string_of_export_t = function
- | Export_tar -> "Export_tar"
- | Export_tgz -> "Export_tgz"
- | Export_checksums alg -> sprintf "Export_checksums %s" alg
- | Export_list -> "Export_list"
-
-and string_of_rw_flag = function RO -> "RO" | RW -> "RW"
+ | Read_directory (OS { insp_root = root }, dir, _) ->
+ sprintf "Read_directory (OS %s, %s)" root dir
+ | Read_directory (Volume dev, dir, _) ->
+ sprintf "Read_directory (Volume %s, %s)" dev dir
let no_callback _ = ()
(* The queue of commands, and a lock and condition to protect it. *)
let q = Q.create ()
+let q_discard = ref false
let q_lock = M.create ()
let q_cond = Cond.create ()
Cond.signal q_cond
)
-let discard_command_queue () = with_lock q_lock (fun () -> Q.clear q)
+let discard_command_queue () =
+ with_lock q_lock (
+ fun () ->
+ Q.clear q;
+ (* Discard the currently running command. *)
+ q_discard := true
+ )
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))
-let disk_usage dev dir cb = send_to_slave (Disk_usage (dev, dir, cb))
-let export_dir_to t dev dir file cb =
- send_to_slave (Export_dir_to (t, dev, dir, file, cb))
+let read_directory src path cb = send_to_slave (Read_directory (src, path, cb))
(*----- Slave thread starts here -----*)
let conn = ref None
let g = ref None
-(* Call 'f ()' with 'dev' mounted read-only. Ensure that everything
+(* Run the callback unless someone set the q_discard flag while
+ * we were running the command.
+ *)
+let callback_if_not_discarded (cb : 'a callback) (arg : 'a) =
+ let discard = with_lock q_lock (fun () -> !q_discard) in
+ if not discard then
+ GtkThread.async cb arg
+
+(* Call 'f ()' with source 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) (
+let with_mount_ro g src (f : unit -> 'a) : 'a =
+ Std.finally (fun () -> g#umount_all ()) (
fun () ->
- G.mount_ro g dev "/";
+ (* Do the mount - could be OS or single volume. *)
+ (match src with
+ | Volume dev -> g#mount_ro dev "/";
+ | OS { insp_mountpoints = mps } ->
+ (* Sort the mountpoint keys by length, shortest first. *)
+ let cmp (a,_) (b,_) = compare (String.length a) (String.length b) in
+ let mps = List.sort ~cmp mps in
+ (* Mount the filesystems. *)
+ List.iter (
+ fun (mp, dev) -> g#mount_ro dev mp
+ ) mps
+ );
f ()
) ()
let rec loop () =
- debug "thread id %d: top of slave loop ..." (Thread.id (Thread.self ()));
+ debug "top of slave loop";
(* Get the next command. *)
let cmd =
with_lock q_lock (
fun () ->
- while Q.is_empty q do
- Cond.wait q_cond q_lock
- done;
+ while Q.is_empty q do Cond.wait q_cond q_lock done;
+ q_discard := false;
Q.pop q
) in
- debug "thread id %d: slave processing command %s ..."
- (Thread.id (Thread.self ())) (string_of_command cmd);
+ debug "slave processing command %s ..." (string_of_command cmd);
(try
GtkThread.async !busy_hook ();
- execute_command cmd;
+ execute_command cmd
with exn ->
- (* If a command fails, clear the command queue and run the
- * failure hook in the main thread.
+ (* If a command or the callback fails, clear the command queue
+ * and run the failure hook in the main thread.
*)
discard_command_queue ();
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 ();
+ let empty = with_lock q_lock (fun () -> Q.is_empty q) in
+ if empty then GtkThread.async !idle_hook ();
if !quit then Thread.exit ();
loop ()
| 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 (
) doms in
let cmp { dom_name = n1 } { dom_name = n2 } = compare n1 n2 in
let doms = List.sort ~cmp doms in
- GtkThread.async cb doms
+ callback_if_not_discarded 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_disk_images 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
+ open_disk_images images cb
- | 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) ->
+ | Read_directory (src, dir, cb) ->
let g = get_g () in
let names, stats, links =
- with_mount_ro g dev (
+ with_mount_ro g src (
fun () ->
- let names = G.ls g dir in (* sorted and without . and .. *)
+ let names = g#ls 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
fun ((name, stat), link) ->
{ dent_name = name; dent_stat = stat; dent_link = link }
) entries in
- GtkThread.async cb entries
-
- | Disk_usage (dev, dir, cb) ->
- let g = get_g () in
- let kb = with_mount_ro g dev (fun () -> G.du g dir) in
- GtkThread.async cb kb
-
- | Export_dir_to (t, dev, dir, file, cb) ->
- let g = get_g () in
- with_mount_ro g dev (
- fun () ->
- (match t with
- | Export_tar -> G.tar_out g
- | Export_tgz -> G.tgz_out g
- | Export_checksums alg -> G.checksums_out g alg
- | Export_list -> G.find0 g) dir file
- );
- GtkThread.async cb ()
+ callback_if_not_discarded cb entries
(* Expect to be connected, and return the current libvirt connection. *)
and get_conn () =
close_g ()
and close_g () =
- (match !g with Some g -> G.close g | None -> ());
+ (match !g with Some g -> g#close () | None -> ());
g := None
and get_disk_images_from_xml xml =
let xml = Xml.parse_string xml in
+
+ (* Return the device nodes. *)
let devices =
match xml with
| Xml.Element ("domain", _, children) ->
List.concat devices
| _ ->
failwith "get_xml_desc didn't return <domain/>" in
- let rec source_of = function (* <source file|dev=...> *)
+
+ (* Look for <source attr_name=attr_val/> and return attr_val. *)
+ let rec source_of attr_name = function
| [] -> 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
+ (try Some (List.assoc attr_name attrs)
+ with Not_found -> source_of attr_name rest)
+ | _ :: rest -> source_of attr_name rest
in
+
+ (* Look for <disk> nodes and return the sources (block devices) of those. *)
let blkdevs =
List.filter_map (
function
- | Xml.Element ("disk", _, children) -> source_of children
+ | Xml.Element ("disk", attrs, children) ->
+ (try
+ let typ = List.assoc "type" attrs in
+ if typ = "file" then source_of "file" children
+ else if typ = "block" then source_of "dev" children
+ else None
+ with
+ Not_found -> None)
| _ -> 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);
+and open_disk_images images cb =
+ debug "opening disk image [%s]" (String.concat "; " images);
close_g ();
- let g' = G.create () in
+ let g' = new Guestfs.guestfs () 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
+ (* Uncomment the next line to pass the verbose flag from the command
+ * line through to libguestfs. This is not generally necessary since
+ * we are not so interested in debugging libguestfs problems at this
+ * level, and the user can always set LIBGUESTFS_DEBUG=1 if they need
+ * to.
+ *)
+ (* g#set_verbose (verbose ());*)
+
+ List.iter g#add_drive_ro images;
+
+ g#launch ();
+
+ (* Get list of filesystems. *)
+ let fses = g#list_filesystems () in
+
+ (* Perform inspection. This can fail, ignore errors. *)
+ let roots =
+ try Array.to_list (g#inspect_os ())
+ with
+ Guestfs.Error msg ->
+ debug "inspection failed (error ignored): %s" msg;
+ [] in
+
+ let oses = List.map (
+ fun root -> {
+ insp_root = root;
+ insp_arch = g#inspect_get_arch root;
+ insp_distro = g#inspect_get_distro root;
+ insp_filesystems = g#inspect_get_filesystems root;
+ insp_hostname = g#inspect_get_hostname root;
+ insp_major_version = g#inspect_get_major_version root;
+ insp_minor_version = g#inspect_get_minor_version root;
+ insp_mountpoints = g#inspect_get_mountpoints root;
+ insp_package_format = g#inspect_get_package_format root;
+ insp_package_management = g#inspect_get_package_management root;
+ insp_product_name = g#inspect_get_product_name root;
+ insp_type = g#inspect_get_type root;
+ insp_windows_systemroot =
+ try Some (g#inspect_get_windows_systemroot root)
+ with Guestfs.Error _ -> None
+ }
+ ) roots in
+ let data = {
+ insp_all_filesystems = fses;
+ insp_oses = oses;
+ } in
+ callback_if_not_discarded cb data
(* guestfs_lstatlist has a "hidden" limit of the protocol message size.
* Call this function, but split the list of names into chunks.
| [] -> []
| 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 = g#lstatlist dir (Array.of_list names') in
let xs = Array.to_list xs in
xs @ lstatlist_wrapper g dir names
| [] -> []
| 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 = g#readlinklist dir (Array.of_list names') in
let xs = Array.to_list xs in
xs @ readlinklist_wrapper g dir names
(* Note the following function is called from the main thread. *)
let exit_thread () =
discard_command_queue ();
- send_to_slave Exit_thread;
+ ignore (send_to_slave Exit_thread);
Thread.join slave_thread
(** The public interface to the slave thread.
Please see HACKING file. *)
-(** {2 Commands and callbacks} *)
+(** {2 Commands and callbacks}
+
+ Commands for libvirt and libguestfs are executed in a separate slave
+ thread. This file describes the interface with that thread that the
+ rest of the program sees.
+
+ Commands are intentionally as high level as possible. Often a
+ single command may perform many libvirt and libguestfs operations
+ before returing a result. This is to make use of the slave thread
+ as simple as possible.
+
+ Commands are executed in a "continuation-passing style" (CPS),
+ which means that you call a function to issue the command, passing
+ in a callback ("continuation"). The function returns immediately.
+ The callback may be called some time later once the issued command
+ completes successfully. Several commands can be queued up for
+ execution. Commands are executed and callbacks are performed in
+ sequence.
+
+ The callback returns the result of the command. The callback does
+ not get invoked if there was an error, or if the command was
+ cancelled before it runs (see {!discard_command_queue}). For some
+ commands the callback can be called multiple times (see
+ documentation below).
+*)
type 'a callback = 'a -> unit
(** A callback function in the main thread which is called when the
- command finishes (successfully).
+ command finishes successfully.
This can also return some data (the ['a] parameter). A command
that returns a list of strings might have callback type [string
(** The main thread uses this as a callback if it doesn't care about
the return value from a command. *)
-val connect : string option -> unit callback -> unit
- (** [connect uri cb] sends the [Connect] message to the slave
- thread.
-
- This causes the slave thread to disconnect from libvirt and
- connect to the libvirt [uri]. If this succeeds, [cb] is called
- in the main thread.
-
- Although you can connect to remote hosts, libguestfs won't
- usually be able to see the drives on those hosts, so it normally
- doesn't make sense to use remote URIs. *)
-
type domain = {
dom_id : int;
dom_name : string;
dom_state : Libvirt.Domain.state;
}
- (** List of domains as returned in the [Get_domains] message callback.
+ (** List of domains as returned in the {!connect} callback. *)
- 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 not [InfoShutoff]). *)
+val connect : string option -> domain list callback -> unit
+ (** [connect uri cb] causes the slave thread to disconnect from
+ libvirt and connect to the libvirt [uri]. If this succeeds,
+ then the list of all domains fetched from libvirt and [cb] is
+ called in the main thread.
-val get_domains : domain list callback -> unit
- (** [get_domains cb] sends the [Get_domains] message to the
- slave thread.
-
- This causes the slave thread to retrieve the list of domains
- from libvirt (active and inactive ones). If this succeeds,
- [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]). *)
+ Although you can connect to remote hosts, libguestfs won't
+ usually be able to see the drives on those hosts, so it normally
+ doesn't make sense to use remote URIs. *)
-val open_domain : string -> rw_flag callback -> unit
- (** [open_domain name cb] sends the [Open_domain] message to the
- slave thread.
+type inspection_data = {
+ insp_all_filesystems : (string * string) list;
+ (** see {!Guestfs.list_filesystems} *)
+ insp_oses : inspection_os list;
+ (** one entry per root (operating system), see {!Guestfs.inspect_os} *)
+}
+ (** The inspection data returned in the callback from
+ {!open_domain} and {!open_images}. *)
+and inspection_os = {
+ insp_root : string; (** see {!Guestfs.inspect_os} *)
+ insp_arch : string;
+ insp_distro : string;
+ insp_filesystems : string array;
+ insp_hostname : string;
+ insp_major_version : int;
+ insp_minor_version : int;
+ insp_mountpoints : (string * string) list;
+ insp_package_format : string;
+ insp_package_management : string;
+ insp_product_name : string;
+ insp_type : string;
+ insp_windows_systemroot : string option;
+}
- 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.
+val open_domain : string -> inspection_data callback -> unit
+ (** [open_domain name cb] retrieves the list of block devices for
+ the libvirt domain [name], creates a libguestfs handle, adds
+ those block devices, launches the handle, and performs
+ inspection.
- 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.
+ If this is successful, then [cb] is called in the main thread
+ with the list of filesystems and the results of inspection.
The slave thread must be connected to libvirt (see {!connect})
else this command will fail. *)
-val open_images : string list -> rw_flag callback -> unit
+val open_images : string list -> inspection_data 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 source = OS of inspection_os | Volume of string
+ (** Source type used by {!read_directory}. *)
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). *)
}
+ (** Directory entry returned by {!read_directory}. *)
-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 read_directory : source -> string -> direntry list callback -> unit
+ (** [read_directory src dir cb] reads the contents of the directory
+ [dir] from source [src], and calls the callback function [cb]
+ with the resulting list of directory entries, if successful.
-val disk_usage : string -> string -> int64 callback -> unit
- (** [disk_usage dev dir cb] sends the [Disk_usage] message to the
- slave thread.
-
- This causes the slave thread to estimate the disk usage of the
- directory (or file) [dir] from volume [dev], and call [cb] with
- the result (size in {b kilobytes}). *)
-
-type export_t =
- | Export_tar (** uncompressed tar archive *)
- | Export_tgz (** gzip compressed tar archive *)
- | Export_checksums of string (** checksums using algorithm *)
- | Export_list (** list of file names, \0-separated *)
- (** Export format used by {!export_dir_to}. *)
-
-val export_dir_to : export_t -> string -> string -> string -> unit callback -> unit
- (** [export_dir_to t dev dir file cb] sends the [Export_dir_to] message
- to the slave thread.
-
- This causes the slave thread to export the directory [dir] on
- device [dev] to the host file called [file]. The precise
- operation (ie. what is exported) is controlled by the type
- [export_t]. When the export has been completed, the callback
- [cb] is called in the main thread.
-
- Libguestfs doesn't offer any way to view progress of this
- operation, which could potentially take a long time. *)
+ The source may be either a filesystem (if [src] is [Volume
+ dev]), or a fully mounted up operating system (if [src] is [OS ...]).
+ In the second case all the mountpoints of the operating system
+ are mounted up so that the path may span mountpoints in the
+ natural way. *)
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)
- stopped. *)
+ queue.
+
+ The currently running command cannot be discarded (because of
+ the design of libguestfs). Instead the callback is discarded,
+ so from the point of view of the main thread, the effect is
+ similar. *)
val exit_thread : unit -> unit
(** [exit_thread ()] causes the slave thread to exit, and returns
(** {2 Hooks}
Hooks are like callbacks, except they hook into special events
- that happen in the slave threads, rather than just being a
- response to commands.
+ that happen in the slave thread, rather than just being a response
+ to commands.
The other difference is that hooks are global variables. You can
only set one hook of each type.
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 Config.package;
+ prerr_string ": tid ";
+ prerr_string (string_of_int (Thread.id (Thread.self ())));
prerr_string ": ";
prerr_string str;
prerr_newline ()
sprintf "%.1fG" (Int64.to_float i /. 1024. /. 1024.)
let unique = let i = ref 0 in fun () -> incr i; !i
+
+let mklabel text =
+ (GMisc.label ~text () :> GObj.widget)
+
+let libguestfs_version_string () =
+ let g = new Guestfs.guestfs () in
+ let v = g#version () in
+ let s =
+ sprintf "%Ld.%Ld.%Ld%s"
+ v.Guestfs.major v.Guestfs.minor v.Guestfs.release v.Guestfs.extra in
+ g#close ();
+ s
+
+let libvirt_version_string () =
+ let v = fst (Libvirt.get_version ()) in
+ sprintf "%d.%d.%d" (v / 1_000_000) ((v / 1_000) mod 1_000) (v mod 1_000)
+
+let (//) = Filename.concat
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, unit, string, unit) format4 -> 'a
(** A printf-like function for writing debugging messages. *)
val unique : unit -> int
(** Return a new integer each time called. *)
+
+val mklabel : string -> GObj.widget
+ (** Convenience function to make a label containing some text. It is
+ returned as a generic widget. *)
+
+val libguestfs_version_string : unit -> string
+ (** Return the version of libguestfs as a string. *)
+
+val libvirt_version_string : unit -> string
+ (** Return the version of libvirt as a string. *)
+
+val (//) : string -> string -> string
+ (** Concatenate two paths. *)
module G = Guestfs
-let (//) = Filename.concat
-
-(* Display state. *)
-type display_state = {
+(* Main window state. *)
+type window_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;
+ view : Filetree.t;
+ vmcombo : GEdit.combo_box GEdit.text_combo;
+ throbber : GMisc.image;
+ throbber_static : GdkPixbuf.pixbuf;
+ statusbar : GMisc.statusbar;
+ statusbar_context : GMisc.statusbar_context;
+ progress_bar : GRange.progress_bar;
}
+(* Set the statusbar text. *)
+let set_statusbar ws msg =
+ ws.statusbar_context#pop ();
+ ignore (ws.statusbar_context#push msg)
+
+let clear_statusbar ws = set_statusbar ws ""
+
+(* Clear the filetree. *)
+let clear_view ws =
+ Filetree.clear ws.view
+
+(* Callback from Connect -> ... menu items. *)
+let rec connect_to ws uri =
+ (match uri with
+ | None -> set_statusbar ws "Connecting to default libvirt ..."
+ | Some uri -> set_statusbar ws (sprintf "Connecting to %s ..." uri)
+ );
+ clear_view ws;
+ Slave.discard_command_queue ();
+ Slave.connect uri (when_connected ws uri)
+
+(* Called back when connected to a new hypervisor. *)
+and when_connected ws uri doms =
+ (match uri with
+ | None -> set_statusbar ws "Connected to default libvirt"
+ | Some uri -> set_statusbar ws (sprintf "Connected to %s" uri)
+ );
+ (* Populate the VM combo box. *)
+ let combo, (model, column) = ws.vmcombo in
+ model#clear ();
+ List.iter (
+ fun { Slave.dom_name = name } ->
+ let row = model#append () in
+ model#set ~row ~column name
+ ) doms
+
+(* When a new domain is selected by the user, eg through vmcombo. *)
+let rec open_domain ws name =
+ set_statusbar ws (sprintf "Opening %s ..." name);
+ clear_view ws;
+ Slave.discard_command_queue ();
+ Slave.open_domain name (when_opened_domain ws name)
+
+(* Called back when domain was opened successfully. *)
+and when_opened_domain ws name data =
+ debug "when_opened_domain callback";
+ set_statusbar ws (sprintf "Opened %s" name);
+ when_opened_common ws name data
+
+(* When a set of disk images is selected by the user. *)
+and open_disk_images ws images =
+ match images with
+ | [] -> ()
+ | images ->
+ set_statusbar ws (sprintf "Opening disk image %s ..."
+ (String.concat " " images));
+ clear_view ws;
+ Slave.discard_command_queue ();
+ Slave.open_images images (when_opened_disk_images ws images)
+
+(* Called back when disk image(s) were opened successfully. *)
+and when_opened_disk_images ws images data =
+ match images with
+ | [] -> ()
+ | image :: _ as images ->
+ debug "when_opened_disk_images callback";
+ set_statusbar ws (sprintf "Opened disk image %s"
+ (String.concat " " images));
+ when_opened_common ws image data
+
+(* Common code for when_opened_domain/when_opened_disk_images. *)
+and when_opened_common ws name data =
+ (* Dump some of the inspection data in debug messages. *)
+ List.iter (fun (dev, t) -> debug "filesystem: %s: %s" dev t)
+ data.Slave.insp_all_filesystems;
+ List.iter (
+ fun { Slave.insp_root = root; insp_type = typ; insp_distro = distro;
+ insp_major_version = major; insp_minor_version = minor } ->
+ debug "root device %s contains %s %s %d.%d" root typ distro major minor;
+ ) data.Slave.insp_oses;
+
+ Filetree.add ws.view name data
+
+let throbber_busy ws () =
+ (*throbber#set_pixbuf animation*)
+ (* XXX Workaround because no binding for GdkPixbufAnimation: *)
+ let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in
+ ws.throbber#set_file file
+
+let throbber_idle ws () =
+ ws.throbber#set_pixbuf ws.throbber_static
+
+(* 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.
+ *)
+let failure ws exn =
+ let title = "Error" in
+ let msg = Printexc.to_string exn in
+ debug "failure hook: %s" msg;
+ let icon = GMisc.image () in
+ icon#set_stock `DIALOG_ERROR;
+ icon#set_icon_size `DIALOG;
+ GToolbox.message_box ~title ~icon msg
+
let rec open_main_window () =
+ (* I prototyped the basic window layout using Glade, but have
+ * implemented it by hand to give us more flexibility.
+ *)
let title = "Guest Filesystem Browser" in
let window = GWindow.window ~width:700 ~height:700 ~title () in
let vbox = GPack.vbox ~packing:window#add () in
- (* Do the menus. *)
+ (* Menus. *)
+ let connect_kvm_item, connect_xen_item, connect_none_item, _, _ =
+ make_menubar window vbox ~packing:vbox#pack () in
+
+ (* Top toolbar. *)
+ let vmcombo, throbber, throbber_static =
+ make_toolbar ~packing:vbox#pack () in
+
+ (* Main part of display is the file tree. *)
+ let view = make_filetree ~packing:(vbox#pack ~expand:true ~fill:true) () in
+
+ (* Status bar and progress bar. *)
+ let hbox = GPack.hbox ~packing:vbox#pack () in
+ let progress_bar = GRange.progress_bar ~packing:hbox#pack () in
+ let statusbar = GMisc.statusbar ~packing:(hbox#pack ~expand:true) () in
+ let statusbar_context = statusbar#new_context ~name:"Standard" in
+ ignore (statusbar_context#push title);
+
+ window#show ();
+
+ (* Construct the window_state struct. *)
+ let ws = {
+ window = window;
+ view = view;
+ vmcombo = vmcombo;
+ throbber = throbber; throbber_static = throbber_static;
+ statusbar = statusbar; statusbar_context = statusbar_context;
+ progress_bar = progress_bar
+ } in
+
+ (* Connect up the callback for menu entries etc. These require the
+ * window_state struct in callbacks.
+ *)
+
+ (* Connect to different hypervisors. *)
+ ignore (connect_kvm_item#connect#activate
+ ~callback:(fun () -> connect_to ws (Some "qemu:///system")));
+ ignore (connect_xen_item#connect#activate
+ ~callback:(fun () -> connect_to ws (Some "xen:///")));
+ ignore (connect_none_item#connect#activate
+ ~callback:(fun () -> connect_to ws None));
+
+ (* VM combo box when changed by the user. *)
+ let combo, (model, column) = ws.vmcombo in
+ ignore (
+ combo#connect#changed
+ ~callback:(
+ fun () ->
+ match combo#active_iter with
+ | None -> () (* nothing selected *)
+ | Some row -> open_domain ws (model#get ~row ~column)
+ )
+ );
+
+ ws
+
+and make_menubar window vbox ~packing () =
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_kvm_item = factory#add_item "_Connect to local KVM hypervisor" in
- let connect_xen_item = factory#add_item "_Connect to local Xen hypervisor" in
+ let connect_kvm_item = factory#add_item "Connect to local _KVM hypervisor" in
+ let connect_xen_item = factory#add_item "Connect to local _Xen hypervisor" in
let connect_none_item = factory#add_item "_Connect to default hypervisor" in
- let connect_uri_item = factory#add_item "_Connect to a libvirt URI ..." in
+ let connect_uri_item = factory#add_item "Connect to a _libvirt URI ..." in
ignore (factory#add_separator ());
let open_image_item =
factory#add_item "_Open disk image ..." ~key:GdkKeysyms._O in
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
+ connect_kvm_item, connect_xen_item, connect_none_item,
+ connect_uri_item, open_image_item
- (* Set up some callbacks which require access to the display_state. *)
- ignore (
- let combo, (model, column) = vmcombo in
- combo#connect#changed
- ~callback:(
- fun () ->
- Option.may (fun row -> open_domain ds (model#get ~row ~column))
- combo#active_iter
- )
- );
-
- ignore (connect_kvm_item#connect#activate
- ~callback:(fun () -> connect ds (Some "qemu:///system")));
- ignore (connect_xen_item#connect#activate
- ~callback:(fun () -> connect ds (Some "xen:///")));
- ignore (connect_none_item#connect#activate
- ~callback:(fun () -> connect ds None));
- ignore (connect_uri_item#connect#activate ~callback:(connect_uri_dialog ds));
- ignore (open_image_item#connect#activate ~callback:(open_image_dialog ds));
-
- (* Return the display state. *)
- ds
-
-(* Convenience function to make a label containing some text. It is
- * returned as a generic widget.
+(* Top toolbar. In fact, not a toolbar because you don't seem to be
+ * able to put a combo box into a toolbar, so it's just an hbox for now.
*)
-and mklabel text =
- (GMisc.label ~text () :> GObj.widget)
+and make_toolbar ~packing () =
+ let hbox = GPack.hbox ~border_width:4 ~packing () in
-(* 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
-
-(* Perform action to open the named libvirt URI. *)
-and connect ds uri =
- (match uri with
- | None -> ds.set_statusbar "Connecting to default libvirt ...";
- | Some uri -> ds.set_statusbar (sprintf "Connecting to %s ..." uri));
- ds.clear_notebook ();
- Slave.discard_command_queue ();
- Slave.connect uri (connected ds uri)
-
-(* 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
-
-(* Perform action to open the named domain. *)
-and open_domain ds name =
- ds.set_statusbar (sprintf "Opening %s ..." name);
- ds.clear_notebook ();
- Slave.discard_command_queue ();
- Slave.open_domain name (opened_domain ds)
-
-(* 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
-
-(* Perform action of opening disk image(s). *)
-and open_images ds images =
- ds.set_statusbar (sprintf "Opening disk image %s ..."
- (String.concat " " images));
- ds.clear_notebook ();
- Slave.discard_command_queue ();
- Slave.open_images images (opened_images ds)
-
-(* 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
+ (* Combo box for displaying virtual machine names. *)
+ hbox#pack (mklabel "Guest: ");
+ let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in
-and _opened ds rw =
- ds.set_statusbar ("Opening filesystems ...");
- ds.clear_notebook ();
+ (* Throbber. *)
+ let static = Throbber.static () in
+ (*let animation = Throbber.animation () in*)
+ let throbber =
+ GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in
- (* Get the list of mountable filesystems. *)
- Slave.get_volumes (got_volume ds rw)
+ vmcombo, throbber, static
-(* This callback is called once for each mountable filesystem that is
- * found in a guest.
- *)
-and got_volume ds rw vol =
- ds.clear_statusbar ();
-
- 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_uri_dialog ds () =
- debug "connect_uri_dialog";
- let title = "Choose a libvirt URI" in
- let ok = "Connect to libvirt" in
- let text = "NB: Remote storage cannot be accessed, so entering
-a libvirt remote URI here will probably not work." in
- let uri = GToolbox.input_string ~title ~ok text in
- match uri with
- | None -> debug "connect_uri_dialog cancelled"; ()
- | Some "" -> debug "connect to default"; connect ds None
- | (Some s) as uri -> debug "connect to %s" s; connect ds uri
-
-(* Open the disk images dialog.
- * XXX This can only deal with a single disk image at the moment, but
- * underlying code can deal with multiple.
- *)
-and open_image_dialog ds () =
- let title = "Choose a disk image" in
- let dlg = GWindow.file_chooser_dialog ~action:`OPEN ~title ~modal:true () in
- dlg#add_button "Open disk image" `OPEN_IMAGE;
- dlg#add_button "Close" `DELETE_EVENT;
-
- let callback = function
- | `DELETE_EVENT -> debug "DELETE_EVENT response"; dlg#destroy ()
- | `OPEN_IMAGE ->
- match dlg#filename with
- | None -> () (* nothing selected in dialog, keep dialog open *)
- | Some filename ->
- debug "OPEN_IMAGE response, filename = %s" filename;
- dlg#destroy ();
- open_images ds [filename]
- in
- ignore (dlg#connect#response ~callback);
-
- dlg#show ()
-
-(* 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 -> connect ds uri
- | Cmdline.Open_disk_image images -> open_images ds images
+and make_filetree ~packing () =
+ let sw =
+ GBin.scrolled_window ~packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in
+ Filetree.create ~packing:sw#add ()
(** 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. *)
+type window_state
-val open_main_window : unit -> display_state
+val open_main_window : unit -> window_state
(** Open the main Gtk window, set up the menus, callbacks and so on. *)
-val failure : display_state -> exn -> unit
+val failure : window_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. *)
+val throbber_busy : window_state -> unit -> unit
+val throbber_idle : window_state -> unit -> unit
+ (** These are callbacks from the slave thread (invoked in the main
+ thread) which are called whenever the throbber should be
+ animated/busy or idle. *)
+
+(*
+ val run_cli_request : window_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