From b9e8c84588873568b7fdfaeb9beb85466e84c8fa Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Sat, 2 Oct 2010 11:33:10 +0100 Subject: [PATCH] guestfs browser 'reboot' --- HACKING | 2 +- Makefile.am | 12 +- README | 7 +- cmdline.ml | 82 -------- cmdline.mli | 30 --- deviceSet.ml | 58 ++++++ deviceSet.mli | 53 +++++ filetree.ml | 607 +++++++++++++++++++++------------------------------------- filetree.mli | 16 +- main.ml | 25 +-- slave.ml | 297 ++++++++++++++-------------- slave.mli | 187 +++++++++--------- utils.ml | 24 ++- utils.mli | 18 +- window.ml | 534 +++++++++++++++++++-------------------------------- window.mli | 36 ++-- 16 files changed, 834 insertions(+), 1154 deletions(-) delete mode 100644 cmdline.ml delete mode 100644 cmdline.mli create mode 100644 deviceSet.ml create mode 100644 deviceSet.mli diff --git a/HACKING b/HACKING index 468162e..0a27b77 100644 --- a/HACKING +++ b/HACKING @@ -64,7 +64,7 @@ Most modules alias short names for some common libvirt and libguestfs 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 diff --git a/Makefile.am b/Makefile.am index 327aea8..cc16b78 100644 --- a/Makefile.am +++ b/Makefile.am @@ -25,11 +25,12 @@ EXTRA_DIST = \ 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 \ @@ -41,13 +42,14 @@ SOURCES = \ 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 @@ -56,7 +58,7 @@ bin_SCRIPTS = guestfs-browser OCAMLPACKAGES = libvirt,guestfs,lablgtk2,extlib,xml-light,threads OCAMLCFLAGS = \ -g \ - -warn-error A \ + -warn-error CDEFLMPSUVYZX \ -thread \ -package $(OCAMLPACKAGES) \ -predicates threads diff --git a/README b/README index b21b50d..d7198b9 100644 --- a/README +++ b/README @@ -12,15 +12,12 @@ script and it will tell you what's missing). 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 diff --git a/cmdline.ml b/cmdline.ml deleted file mode 100644 index 43e0bf6..0000000 --- a/cmdline.ml +++ /dev/null @@ -1,82 +0,0 @@ -(* 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" diff --git a/cmdline.mli b/cmdline.mli deleted file mode 100644 index 79b411f..0000000 --- a/cmdline.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* 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}. *) diff --git a/deviceSet.ml b/deviceSet.ml new file mode 100644 index 0000000..b51391e --- /dev/null +++ b/deviceSet.ml @@ -0,0 +1,58 @@ +(* 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 diff --git a/deviceSet.mli b/deviceSet.mli new file mode 100644 index 0000000..424fb75 --- /dev/null +++ b/deviceSet.mli @@ -0,0 +1,53 @@ +(* 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 diff --git a/filetree.ml b/filetree.ml index 797c3df..0737820 100644 --- a/filetree.ml +++ b/filetree.ml @@ -16,45 +16,67 @@ * 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 = "Loading ..." + +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 @@ -63,6 +85,7 @@ let rec filetree dev rw = 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)); @@ -72,6 +95,7 @@ let rec filetree dev rw = 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 @@ -86,148 +110,17 @@ let rec filetree dev rw = 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 "Loading ..."; - 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 @@ -235,10 +128,8 @@ and markup_escape name = 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 = @@ -296,249 +187,177 @@ and markup_of_date time = (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 "%s: %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 "%s: %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 diff --git a/filetree.mli b/filetree.mli index 7321a4f..46fd39a 100644 --- a/filetree.mli +++ b/filetree.mli @@ -26,8 +26,16 @@ 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. *) diff --git a/main.ml b/main.ml index 9a72113..1fb7ce0 100644 --- a/main.ml +++ b/main.ml @@ -20,34 +20,27 @@ open Printf 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. diff --git a/slave.ml b/slave.ml index ba45cfb..94fce75 100644 --- a/slave.ml +++ b/slave.ml @@ -23,7 +23,6 @@ open Utils module C = Libvirt.Connect module Cond = Condition module D = Libvirt.Domain -module G = Guestfs module M = Mutex module Q = Queue @@ -32,14 +31,10 @@ type 'a callback = 'a -> unit (* 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; @@ -47,49 +42,46 @@ and domain = { 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 _ = () @@ -115,6 +107,7 @@ let with_lock m f = (* 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 () @@ -127,17 +120,18 @@ let send_to_slave cmd = 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 -----*) @@ -150,46 +144,63 @@ let quit = ref false 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 () @@ -202,9 +213,7 @@ and execute_command = function | 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 ( @@ -215,44 +224,24 @@ and execute_command = function ) 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 @@ -267,24 +256,7 @@ and execute_command = function 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 () = @@ -304,11 +276,13 @@ and close_all () = 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) -> @@ -321,20 +295,28 @@ and get_disk_images_from_xml xml = List.concat devices | _ -> failwith "get_xml_desc didn't return " in - let rec source_of = function (* *) + + (* Look for 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 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 @@ -342,44 +324,61 @@ and get_disk_images_from_xml xml = (* 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. @@ -388,7 +387,7 @@ 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 = g#lstatlist dir (Array.of_list names') in let xs = Array.to_list xs in xs @ lstatlist_wrapper g dir names @@ -397,7 +396,7 @@ 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 = g#readlinklist dir (Array.of_list names') in let xs = Array.to_list xs in xs @ readlinklist_wrapper g dir names @@ -407,5 +406,5 @@ let slave_thread = Thread.create loop () (* 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 diff --git a/slave.mli b/slave.mli index 1e310bc..d36ef04 100644 --- a/slave.mli +++ b/slave.mli @@ -19,11 +19,35 @@ (** 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 @@ -38,131 +62,92 @@ val no_callback : 'a callback (** 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 @@ -171,8 +156,8 @@ val exit_thread : unit -> unit (** {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. diff --git a/utils.ml b/utils.ml index 94a59a0..9b6f3bd 100644 --- a/utils.ml +++ b/utils.ml @@ -29,14 +29,12 @@ 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 Config.package; + prerr_string ": tid "; + prerr_string (string_of_int (Thread.id (Thread.self ()))); prerr_string ": "; prerr_string str; prerr_newline () @@ -62,3 +60,21 @@ let human_size_1k i = 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 diff --git a/utils.mli b/utils.mli index 1959ef6..6479fea 100644 --- a/utils.mli +++ b/utils.mli @@ -35,11 +35,6 @@ val set_verbose_flag : unit -> unit 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. *) @@ -55,3 +50,16 @@ val human_size_1k : int64 -> string 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. *) diff --git a/window.ml b/window.ml index f58d76f..323e847 100644 --- a/window.ml +++ b/window.ml @@ -22,38 +22,199 @@ open Utils 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 @@ -67,331 +228,30 @@ let rec open_main_window () = 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 = "" ^ text ^ "" 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 () diff --git a/window.mli b/window.mli index 916bb15..97aab79 100644 --- a/window.mli +++ b/window.mli @@ -19,31 +19,25 @@ (** 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. *) +*) -- 1.8.3.1