From c79fc07ff71926b3bf956ff296336f6f71bb3b1e Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 14 Dec 2010 19:50:01 +0000 Subject: [PATCH] Prepare for first binary release. --- .depend | 4 +- .gitignore | 3 + HACKING | 7 ++- Makefile.am | 41 ++++++++++++- README | 15 ----- cmdline.ml | 8 ++- configure.ac | 7 +++ filetree.ml | 23 ++++--- filetree.mli | 11 +--- filetree_ops.ml | 60 +++++++++++++------ filetree_ops.mli | 2 + filetree_type.ml | 30 +++++++--- filetree_type.mli | 10 ++-- guestfs-browser.pod | 150 ++++++++++++++++++++++++++++++++++++++++++++++ guestfs-browser.spec.in | 15 +++-- html/pod.css | 155 ++++++++++++++++++++++++++++++++++++++++++++++++ main.ml | 1 + slave.ml | 57 ++++++++++++++++++ slave.mli | 11 ++++ window.ml | 16 ----- window.mli | 5 ++ 21 files changed, 533 insertions(+), 98 deletions(-) create mode 100644 guestfs-browser.pod create mode 100644 html/pod.css diff --git a/.depend b/.depend index 742d484..4df490d 100644 --- a/.depend +++ b/.depend @@ -1,6 +1,6 @@ cmdline.cmi: -cmdline.cmo: utils.cmi cmdline.cmi -cmdline.cmx: utils.cmx cmdline.cmi +cmdline.cmo: utils.cmi config.cmi cmdline.cmi +cmdline.cmx: utils.cmx config.cmx cmdline.cmi config.cmi: config.cmo: config.cmi config.cmx: config.cmi diff --git a/.gitignore b/.gitignore index 9d1ead6..38b0473 100644 --- a/.gitignore +++ b/.gitignore @@ -17,7 +17,10 @@ configure doc/ guestfs-browser-*.tar.gz guestfs-browser +guestfs-browser.1 guestfs-browser.spec +html/*.html install-sh missing +pod2htm?.tmp stamp-h1 diff --git a/HACKING b/HACKING index 0a27b77..28b25f7 100644 --- a/HACKING +++ b/HACKING @@ -1,5 +1,5 @@ -This document describes the software architecture of the Guestfs -Browser, useful if you want to hack on it. +This document describes the software architecture of the +guestfs-browser, useful if you want to hack on it. About OCaml ----------- @@ -7,6 +7,7 @@ About OCaml First of all about OCaml: Read the tutorial and other resources available from this site: + http://caml.inria.fr/ http://ocaml-tutorial.org/ If you are using emacs, install tuareg-mode instead of using the @@ -30,7 +31,7 @@ Threads and messages Because libvirt and libguestfs API calls are usually long-running, we have to use threads, making these API calls in one thread, while -another thread keeps the display updated. In Guestfs Browser we use +another thread keeps the display updated. In guestfs-browser we use two threads, and send messages between them. The main thread keeps the display updated and runs the glib main loop. The slave thread issues libvirt and libguestfs API calls serially. There is a FIFO diff --git a/Makefile.am b/Makefile.am index 2967d7e..57023f2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -21,7 +21,10 @@ EXTRA_DIST = \ $(SOURCES) \ HACKING \ Throbber.png Throbber.gif \ - .gitignore guestfs-browser.spec + .gitignore guestfs-browser.spec \ + guestfs-browser.pod \ + guestfs-browser.1 \ + html/pod.css CLEANFILES = *.cmi *.cmo *.cmx *.o guestfs-browser @@ -101,6 +104,42 @@ throbber.ml: Throbber.png Throbber.gif .ml.cmx: $(OCAMLFIND) ocamlopt $(OCAMLCFLAGS) -c $< -o $@ +# Man page. +man_MANS = guestfs-browser.1 + +if HAVE_PERLDOC + +guestfs-browser.1: guestfs-browser.pod + pod2man \ + --section 1 \ + -c "Virtualization Support" \ + --release "$(PACKAGE_NAME)-$(PACKAGE_VERSION)" \ + $< > $@ + +noinst_DATA = \ + html/guestfs-browser.1.html + +html/guestfs-browser.1.html: guestfs-browser.pod + mkdir -p html + pod2html \ + --css 'pod.css' \ + --htmldir html \ + --outfile html/guestfs-browser.1.html \ + guestfs-browser.pod + +endif + +# Maintainer website update. +HTMLFILES = \ + html/guestfs-browser.1.html + +WEBSITEDIR = $(HOME)/d/redhat/websites/libguestfs + +website: $(HTMLFILES) + cp $(HTMLFILES) $(WEBSITEDIR) + +CLEANFILES += $(HTMLFILES) pod2*.tmp + # Convert internal documentation to HTML. docs: rm -rf doc diff --git a/README b/README index d7198b9..4b8ffef 100644 --- a/README +++ b/README @@ -1,5 +1,3 @@ ->>> This is alpha quality software. Read 'HACKING' and 'TODO'. <<< - Guest filesystem browser Copyright (C) 2010 Red Hat Inc. @@ -9,16 +7,3 @@ script and it will tell you what's missing). autoreconf -i # if using the git version ./configure make - -We strongly suggest you run the program like this: - - guestfs-browser [--verbose] --connect qemu:///system -or: - guestfs-browser [--verbose] disk.img - ---verbose enables debug level messages and is recommended. - ---connect tells the program which libvirt URI to connect to. - -Note that libguestfs cannot access remote storage, so accessing a -remote libvirt URI will usually not work. diff --git a/cmdline.ml b/cmdline.ml index e0f244b..bab5768 100644 --- a/cmdline.ml +++ b/cmdline.ml @@ -25,6 +25,10 @@ type cli_request = | Open_guest of string | Open_images of (string * string option) list +let display_version () = + printf "%s %s\n" Config.package Config.version; + exit 0 + let format = ref None let images = ref [] let guests = ref [] @@ -51,8 +55,8 @@ let argspec = Arg.align [ "--format", Arg.String set_format, "format Set format"; "-v", Arg.Unit set_verbose_flag, " Enable debugging messages"; "--verbose", Arg.Unit set_verbose_flag, " Enable debugging messages"; - "-V", Arg.Unit set_verbose_flag, " Display version and exit"; - "--version", Arg.Unit set_verbose_flag, " Display version and exit"; + "-V", Arg.Unit display_version, " Display version and exit"; + "--version", Arg.Unit display_version, " Display version and exit"; "-x", Arg.Unit set_trace_flag, " Enable tracing of libguestfs calls"; ] diff --git a/configure.ac b/configure.ac index 477fc85..2463389 100644 --- a/configure.ac +++ b/configure.ac @@ -71,6 +71,13 @@ fi dnl Check for gdk_pixbuf_mlsource program. AC_PATH_PROGS([GDK_PIXBUF_MLSOURCE], [gdk_pixbuf_mlsource]) +dnl Optional programs. +AC_CHECK_PROG(PERLDOC,[perldoc],[perldoc],[no]) +if test "x$PERLDOC" = "xno" ; then + AC_MSG_WARN([perldoc not found - install perl to make man pages]) +fi +AM_CONDITIONAL(HAVE_PERLDOC,[test "$perldoc" != "no"]) + AC_CONFIG_HEADERS([config.h]) AC_CONFIG_FILES([Makefile config.ml guestfs-browser.spec]) AC_OUTPUT diff --git a/filetree.ml b/filetree.ml index ecdba77..c4f62ab 100644 --- a/filetree.ml +++ b/filetree.ml @@ -30,7 +30,7 @@ module G = Guestfs type t = Filetree_type.t -let rec create ?status ~packing () = +let rec create ~packing () = let view = GTree.view ~packing () in (*view#set_rules_hint true;*) (*view#selection#set_mode `MULTIPLE; -- add this later *) @@ -86,7 +86,6 @@ let rec create ?status ~packing () = index_col = index_col; mode_col = mode_col; name_col = name_col; size_col = size_col; date_col = date_col; link_col = link_col; - status = status } in (* Open a context menu when a button is pressed. *) @@ -139,7 +138,7 @@ and button_press ({ model = model; view = view } as t) ev = let row = model#get_iter path in let hdata = get_hdata t row in match hdata with - | _, (Loading | ErrorMessage _) -> None + | _, (Loading | ErrorMessage _ | Info _) -> None | _, (Top _ | Directory _ | File _) -> Some (path, hdata) ) paths in @@ -177,7 +176,7 @@ and make_context_menu t paths = let item = factory#add_item "Directory information" in item#misc#set_sensitive false; let item = factory#add_item "Space used by directory" in - item#misc#set_sensitive false; + ignore (item#connect#activate ~callback:(disk_usage t path)); ignore (factory#add_separator ()); let item = factory#add_item "Download ..." in item#misc#set_sensitive false; @@ -412,7 +411,7 @@ and expand_row ({ model = model; hash = hash } as t) row _ = | _, File _ | IsLeaf, _ -> assert false (* Node should not exist in the tree. *) - | NodeNotStarted, (Loading | ErrorMessage _) -> assert false + | NodeNotStarted, (Loading | ErrorMessage _ | Info _) -> 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 = @@ -437,13 +436,14 @@ and when_read_directory ({ model = model } as t) path entries = model#set ~row ~column:t.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. + (* Remove the placeholder "Loading" 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 _ -> () + let hdata = IsLeaf, Loading in + let row = find_child_node_by_hdata t row hdata in + ignore (model#remove row) + with Invalid_argument _ | Not_found -> () ); (* The original directory entry has now been loaded, so @@ -473,6 +473,3 @@ and when_read_directory_fail ({ model = model } as t) path exn = | exn -> (* unexpected exception: re-raise it *) raise exn - -let set_status_fn t status = - t.status <- Some status diff --git a/filetree.mli b/filetree.mli index cd047cc..9207cf7 100644 --- a/filetree.mli +++ b/filetree.mli @@ -30,15 +30,9 @@ type t (** A filetree widget. Actually an opaque object which contains the widget and other data. Use the accessors below. *) -val create : ?status:(string -> unit) -> packing:(GObj.widget -> unit) -> unit -> t +val create : packing:(GObj.widget -> unit) -> unit -> t (** Create a new filetree widget (empty). - In the optional [?status] parameter you can pass in some - function that updates a status bar. This function will be - called by the filetree whenever the user should be told about - some ordinary event having happened (for example, that a file is - being downloaded or has finished downloading). - [~packing] is the required packing for the widget. *) val clear : t -> unit @@ -49,6 +43,3 @@ val add : t -> string -> Slave.inspection_data -> unit 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. *) - -val set_status_fn : t -> (string -> unit) -> unit - (** Set or update the [status] function. *) diff --git a/filetree_ops.ml b/filetree_ops.ml index c273f30..264c46e 100644 --- a/filetree_ops.ml +++ b/filetree_ops.ml @@ -58,13 +58,7 @@ let rec download_file ({ model = model } as t) path () = dlg#destroy (); (* Download the file. *) - update_status t - (sprintf "Downloading %s to %s ..." pathname localfile); - Slave.download_file src pathname localfile - (when_downloaded_file t pathname localfile) - -and when_downloaded_file t _ localfile () = - update_status t (sprintf "Finished downloading %s" localfile) + Slave.download_file src pathname localfile Slave.no_callback (* Download a directory as a tarball. *) let rec download_dir_tarball ({ model = model } as t) format path () = @@ -95,13 +89,8 @@ let rec download_dir_tarball ({ model = model } as t) format path () = dlg#destroy (); (* Download the directory. *) - update_status t - (sprintf "Downloading %s to %s ..." pathname localfile); Slave.download_dir_tarball src pathname format localfile - (when_downloaded_dir_tarball t pathname localfile) - -and when_downloaded_dir_tarball t _ localfile () = - update_status t (sprintf "Finished downloading %s" localfile) + Slave.no_callback let rec download_dir_find0 ({ model = model } as t) path () = let row = model#get_iter path in @@ -136,10 +125,43 @@ let rec download_dir_find0 ({ model = model } as t) path () = dlg#destroy (); (* Download the directory. *) - update_status t - (sprintf "Downloading filenames in %s to %s ..." pathname localfile); - Slave.download_dir_find0 src pathname localfile - (when_downloaded_dir_find0 t pathname localfile) + Slave.download_dir_find0 src pathname localfile Slave.no_callback + +let has_child_node_equals t row hdata = + try ignore (find_child_node_by_hdata t row hdata); true + with Not_found -> false + +(* Calculate disk space used by a directory. *) +let rec disk_usage ({ model = model } as t) path () = + t.view#expand_row path; + + let row = model#get_iter path in + let src, pathname = get_pathname t row in + debug "disk_usage %s" pathname; + + (* See if this node already has an Info "disk_usage" child node. If + * so they don't recreate it. + *) + let hdata = IsLeaf, Info "disk_usage" in + if not (has_child_node_equals t row hdata) then ( + (* Create the child node first. *) + let row = model#insert ~parent:row 0 in + store_hdata t row hdata; + model#set ~row ~column:t.name_col "Calculating disk usage ..."; + + Slave.disk_usage src pathname (when_disk_usage t path) + ) + +and when_disk_usage ({ model = model } as t) path kbytes = + let row = model#get_iter path in -and when_downloaded_dir_find0 t _ localfile () = - update_status t (sprintf "Finished downloading %s" localfile) + (* Find the Info "disk_usage" child node add above, and replace the + * text in it with the final size. + *) + try + let hdata = IsLeaf, Info "disk_usage" in + let row = find_child_node_by_hdata t row hdata in + let msg = sprintf "Disk usage: %Ld KB" kbytes in + model#set ~row ~column:t.name_col msg + with + Not_found -> () diff --git a/filetree_ops.mli b/filetree_ops.mli index dacbd88..8b6e0e3 100644 --- a/filetree_ops.mli +++ b/filetree_ops.mli @@ -28,6 +28,8 @@ (**/**) +val disk_usage : Filetree_type.t -> Gtk.tree_path -> unit -> unit + val download_file : Filetree_type.t -> Gtk.tree_path -> unit -> unit val download_dir_tarball : Filetree_type.t -> Slave.download_dir_tarball_format -> Gtk.tree_path -> unit -> unit diff --git a/filetree_type.ml b/filetree_type.ml index 9c80e97..9f2bc64 100644 --- a/filetree_type.ml +++ b/filetree_type.ml @@ -28,7 +28,6 @@ type t = { size_col : int64 GTree.column; date_col : string GTree.column; link_col : string GTree.column; - mutable status : (string -> unit) option; } and hdata = state_t * content_t @@ -48,6 +47,7 @@ and state_t = and content_t = | Loading (* special "loading ..." node *) | ErrorMessage of string (* error message node *) + | Info of string (* information node (eg. disk usage) *) | 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 *) @@ -64,6 +64,23 @@ let get_hdata { model = model; hash = hash; index_col = index_col } row = try Hashtbl.find hash index with Not_found -> assert false +(* Iterate over children of node, looking for matching hdata. *) +let find_child_node_by_hdata ({ model = model } as t) row hdata = + let rec loop row = + if hdata = get_hdata t row then + row + else if model#iter_next row then + loop row + else + raise Not_found + in + + if not (model#iter_has_child row) then + raise Not_found; + + let first_child = model#iter_children (Some row) in + loop first_child + (* 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. * @@ -78,9 +95,9 @@ let rec get_pathname ({ model = model } as t) row = let parent = model#iter_parent row in match hdata, parent with - | (IsLeaf, Loading), Some parent -> + | (IsLeaf, (Loading|ErrorMessage _|Info _)), Some parent -> get_pathname t parent - | (IsLeaf, Loading), None -> + | (IsLeaf, (Loading|ErrorMessage _|Info _)), None -> assert false | (_, Directory { Slave.dent_name = name }), Some parent | (_, File { Slave.dent_name = name }), Some parent -> @@ -94,9 +111,4 @@ let rec get_pathname ({ model = model } as t) row = | (_, File _), None -> assert false | (_, Loading), _ -> assert false | (_, ErrorMessage _), _ -> assert false - -(* Update the status bar. *) -let update_status { status = f } msg = - match f with - | None -> () (* user didn't give us a [status] function to call *) - | Some f -> f msg + | (_, Info _), _ -> assert false diff --git a/filetree_type.mli b/filetree_type.mli index af36dee..18a5187 100644 --- a/filetree_type.mli +++ b/filetree_type.mli @@ -35,7 +35,6 @@ type t = { size_col : int64 GTree.column; date_col : string GTree.column; link_col : string GTree.column; - mutable status : (string -> unit) option; } and hdata = state_t * content_t @@ -49,6 +48,7 @@ and state_t = and content_t = | Loading | ErrorMessage of string + | Info of string | Top of Slave.source | Directory of Slave.direntry | File of Slave.direntry @@ -57,10 +57,12 @@ val store_hdata : t -> Gtk.tree_iter -> hdata -> unit val get_hdata : t -> Gtk.tree_iter -> hdata (* Store/retrieve hdata structure in a model row. *) +val find_child_node_by_hdata : t -> Gtk.tree_iter -> hdata -> Gtk.tree_iter + (* [find_child_node_by_hdata t row hdata] searches the direct children + of [row] looking for one which exactly matches [hdata] and returns + that child. If no child found, raises [Not_found]. *) + val get_pathname : t -> Gtk.tree_iter -> Slave.source * string (* Get the full path to a row by chasing up through the tree to the top. This also returns the source (eg. operating system or single volume). *) - -val update_status : t -> string -> unit - (* Update the status bar. *) diff --git a/guestfs-browser.pod b/guestfs-browser.pod new file mode 100644 index 0000000..be73b61 --- /dev/null +++ b/guestfs-browser.pod @@ -0,0 +1,150 @@ +=encoding utf8 + +=head1 NAME + +guestfs-browser - Guest filesystem browser + +=head1 SYNOPSIS + + guestfs-browser [--options] + + guestfs-browser [--options] -d domname + + guestfs-browser [--options] -a disk.img [-a disk.img [...]] + +=head1 DESCRIPTION + +The guest filesystem browser is a graphical program for browsing +virtual machine filesystems and disk images interactively. + +If you need to make scripted changes or browse disk images from the +command line, we suggest you look at L or +L instead. If you want to mount a disk image or +virtual machine disk on the host, use L. + +To start guestfs-browser with an empty window, use: + + guestfs-browser + +To start guestfs-browser pointing to a disk image file called +C, use: + + guestfs-browser -a disk.img + +To start guestfs-browser pointing to a libvirt domain called C, +use: + + guestfs-browser [-c libvirtURI] -d guest + +Note that this only works for local libvirt guests (at least the +browser must be able to read the disks locally). + +The program does not need to be run as root, unless root is required +in order to access the disk images. Currently guestfs-browser only +accesses the disk image read only. It is therefore safe to use +guestfs-browser on live virtual machines, but you may see strange or +inconsistent results. + +=head1 OPTIONS + +=over 4 + +=item B<-a> + +=item B<--add> + +Add I which should be a disk image. You can supply multiple +disk images by repeating this option. + +The format of the disk image is auto-detected. To override this and +force a particular format use the I<--format=..> option. + +=item B<-c> URI + +=item B<--connect> URI + +If using libvirt, connect to the given I. If omitted, then we +connect to the default libvirt hypervisor. + +If you specify guest block devices directly (I<-a>), then libvirt is +not used at all. + +=item B<-d> guest + +=item B<--domain> guest + +Add all the disks from the named libvirt guest. + +=item B<--format raw|qcow2|..> + +=item B<--format ""> + +The default for the I<-a> option is to auto-detect the format of the +disk image. Using this forces the disk format for I<-a> options which +follow on the command line. Using I<--format> with no argument +switches back to auto-detection for subsequent I<-a> options. + +For example: + + guestfs-browser --format raw -a disk.img + +forces raw format (no auto-detection) for C. + + guestfs-browser --format raw -a disk.img --format "" -a another.img + +forces raw format (no auto-detection) for C and reverts to +auto-detection for C. + +If you have untrusted raw-format guest disk images, you should use +this option to specify the disk format. This avoids a possible +security problem with malicious guests (CVE-2010-3851). + +=item B<-v> + +=item B<--verbose> + +Enable verbose messages for debugging. + +=item B<-V> + +=item B<--version> + +Display version number and exit. + +=item B<-x> + +Enable tracing of libguestfs API calls. + +=back + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L, +L. + +=head1 AUTHOR + +Richard W.M. Jones L + +=head1 COPYRIGHT + +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., 675 Mass Ave, Cambridge, MA 02139, USA. diff --git a/guestfs-browser.spec.in b/guestfs-browser.spec.in index 52014e8..57265bc 100644 --- a/guestfs-browser.spec.in +++ b/guestfs-browser.spec.in @@ -11,14 +11,22 @@ Source0: http://people.redhat.com/~rjones/guestfs-browser/files/guestfs-b BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n) +BuildRequires: libguestfs-devel >= 1.7.9 +BuildRequires: libvirt-devel BuildRequires: ocaml -BuildRequires: ocaml-ocamldoc BuildRequires: ocaml-findlib-devel BuildRequires: ocaml-libvirt-devel BuildRequires: ocaml-libguestfs-devel BuildRequires: ocaml-xml-light-devel BuildRequires: ocaml-extlib-devel BuildRequires: ocaml-lablgtk-devel +BuildRequires: /usr/bin/pod2man +BuildRequires: /usr/bin/pod2html + +Requires: libguestfs >= 1.7.9 + +# Only needed to build the internal documentation. +#BuildRequires: ocaml-ocamldoc %description @@ -37,7 +45,6 @@ line. %build %configure make %{?_smp_mflags} -make docs %install @@ -52,10 +59,10 @@ rm -rf $RPM_BUILD_ROOT %files %defattr(-,root,root,-) %doc COPYING HACKING README -%doc doc %{_bindir}/guestfs-browser +%{_mandir}/man1/guestfs-browser.1* %changelog -* Fri Jul 9 2010 Richard W.M. Jones - @VERSION@-1 +* Tue Dec 14 2010 Richard W.M. Jones - @VERSION@-1 - Initial RPM release. diff --git a/html/pod.css b/html/pod.css new file mode 100644 index 0000000..d90ebb5 --- /dev/null +++ b/html/pod.css @@ -0,0 +1,155 @@ +/* CSS to make pod2html files look a little bit better. */ + +body { + margin-left: 4em; +} + +body p, body ul, ol, body dl { + margin-left: 2em; + width: 31em; +} + +pre { + width: 31em; +} + +li { + padding-bottom: 0.5em; +} + +/* Code sections. */ + +pre { + background-color: #f8f8f8; + color: rgb(204,0,0); + font-weight: 550; + border-left: 6px solid rgb(204,64,64); + padding: 6px; + margin-left: 1em; + font-size: 120%; +} + +/* Bold, italic in man pages. */ +b, strong { + color: rgb(204,0,0); +} + +i, em { + color: rgb(204,0,0); +} + +/* Name heading. */ + +body > h1:first-of-type { + display: none; +} + +body > h1:first-of-type + p { + font-size: 125%; + font-weight: bold; + color: rgb(204,0,0); + margin-left: -32px; +} + +/* Warning heading in man pages. */ +a[name="warning"] { + -moz-border-radius-topleft: 5px; + -moz-border-radius-topright: 5px; + border-radius-topleft: 5px; + border-radius-topright: 5px; + + color: white; + background-color: rgb(204,0,0); +} +a[name="warning"]:before { + content: "\00a0\00a0\00a0"; +} +a[name="warning"]:after { + content: "\00a0\00a0\00a0"; +} + +/* Put the index on the right hand side in a floating box. */ +div[name="index"] { + float: right; + width: 18em; + border-left: 3em solid white; + background-color: #fcfcfc; + margin-top: 32px; + padding-top: 0px; + margin-left: 1em; + padding-left: 1em; + padding-right: 1em; + font-size: 90%; +} + +div[name="index"] a[href] { + text-decoration: none; +} + +div[name="index"] a[href]:hover { + text-decoration: underline; +} + +div[name="index"] a[href]:before { + content: '#\00a0'; + color: rgb(204,0,0); + font-size: x-small; +} + +div[name="index"] > ul { + width: 17em; + list-style: none; + margin-left: 0px; + margin-right: 0px; + padding-left: 0px; + padding-right: 0px; +} + +div[name="index"] > ul > li { + margin-bottom: 0.5em; +} + +div[name="index"] > ul ul { + width: 16em; + list-style: none; + margin-left: 0px; + margin-right: 0px; + padding-left: 0px; + padding-right: 0px; + margin-bottom: 0.5em; +} + +div[name="index"] > ul > ul li { + display: inline; + margin-right: 1em; +} + +/* +div[name="index"] > ul > ul li:after { + color: #ccc; + content: '\2014'; +} +*/ + +/* Get rid of those horrible
's :-( */ +hr { display: none; } + +/* Demote

's and set rest of headers relative. */ +h1 { + font-size: 100%; + color: black; + border-bottom: solid 1px rgb(204,0,0); +} + +h2 { + font-size: 95%; + border-bottom: none; +} + +h3 { + font-size: 90%; +} + +h4 { + font-size: 85%; +} diff --git a/main.ml b/main.ml index fafe7d6..82e4603 100644 --- a/main.ml +++ b/main.ml @@ -37,6 +37,7 @@ let () = Slave.set_failure_hook (Window.failure ws); Slave.set_busy_hook (Window.throbber_busy ws); Slave.set_idle_hook (Window.throbber_idle ws); + Slave.set_status_hook (Window.set_statusbar ws); Slave.set_progress_hook (Window.progress ws); (* What did the user request on the command line? *) diff --git a/slave.ml b/slave.ml index 17f00b7..880a2b1 100644 --- a/slave.ml +++ b/slave.ml @@ -32,6 +32,7 @@ type 'a callback = 'a -> unit type command = | Exit_thread | Connect of string option * domain list callback + | Disk_usage of source * string * int64 callback | Download_dir_find0 of source * string * string * unit callback | Download_dir_tarball of source * string * download_dir_tarball_format * string * unit callback | Download_file of source * string * string * unit callback @@ -80,6 +81,8 @@ let rec string_of_command = function | Exit_thread -> "Exit_thread" | Connect (Some name, _) -> sprintf "Connect %s" name | Connect (None, _) -> "Connect NULL" + | Disk_usage (src, remotedir, _) -> + sprintf "Disk_usage (%s, %s)" (string_of_source src) remotedir | Download_dir_find0 (src, remotedir, localfile, _) -> sprintf "Download_dir_find0 (%s, %s, %s)" (string_of_source src) remotedir localfile @@ -120,11 +123,13 @@ let no_callback _ = () let failure_hook = ref (fun _ -> ()) let busy_hook = ref (fun _ -> ()) let idle_hook = ref (fun _ -> ()) +let status_hook = ref (fun _ -> ()) let progress_hook = ref (fun _ -> ()) let set_failure_hook cb = failure_hook := cb let set_busy_hook cb = busy_hook := cb let set_idle_hook cb = idle_hook := cb +let set_status_hook cb = status_hook := cb let set_progress_hook cb = progress_hook := cb (* Execute a function, while holding a mutex. If the function @@ -163,6 +168,8 @@ let discard_command_queue () = ) let connect ?fail uri cb = send_to_slave ?fail (Connect (uri, cb)) +let disk_usage ?fail src remotedir cb = + send_to_slave ?fail (Disk_usage (src, remotedir, cb)) let download_dir_find0 ?fail src remotedir localfile cb = send_to_slave ?fail (Download_dir_find0 (src, remotedir, localfile, cb)) let download_dir_tarball ?fail src remotedir format localfile cb = @@ -215,6 +222,11 @@ let with_mount_ro g src (f : unit -> 'a) : 'a = f () ) () +(* Update the status bar. *) +let status fs = + let f str = GtkThread.async !status_hook str in + ksprintf f fs + let rec loop () = debug "top of slave loop"; @@ -254,6 +266,10 @@ and execute_command = function close_all () | Connect (name, cb) -> + let printable_name = + match name with None -> "default hypervisor" | Some uri -> uri in + status "Connecting to %s ..." printable_name; + close_all (); conn := Some (C.connect_readonly ?name ()); @@ -267,17 +283,38 @@ 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 + + status "Connected to %s" printable_name; callback_if_not_discarded cb doms + | Disk_usage (src, remotedir, cb) -> + status "Calculating disk usage of %s ..." remotedir; + + let g = get_g () in + let r = + with_mount_ro g src ( + fun () -> + g#du remotedir + ) in + + status "Finished calculating disk usage of %s" remotedir; + callback_if_not_discarded cb r + | Download_dir_find0 (src, remotedir, localfile, cb) -> + status "Downloading %s filenames to %s ..." remotedir localfile; + let g = get_g () in with_mount_ro g src ( fun () -> g#find0 remotedir localfile ); + + status "Finished downloading %s" localfile; callback_if_not_discarded cb () | Download_dir_tarball (src, remotedir, format, localfile, cb) -> + status "Downloading %s to %s ..." remotedir localfile; + let g = get_g () in let f = match format with | Tar -> g#tar_out @@ -288,17 +325,25 @@ and execute_command = function fun () -> f remotedir localfile ); + + status "Finished downloading %s" localfile; callback_if_not_discarded cb () | Download_file (src, remotefile, localfile, cb) -> + status "Downloading %s to %s ..." remotefile localfile; + let g = get_g () in with_mount_ro g src ( fun () -> g#download remotefile localfile ); + + status "Finished downloading %s" localfile; callback_if_not_discarded cb () | Open_domain (name, cb) -> + status "Opening %s ..." name; + let conn = get_conn () in let dom = D.lookup_by_name conn name in let xml = D.get_xml_desc dom in @@ -306,9 +351,13 @@ and execute_command = function open_disk_images images cb | Open_images (images, cb) -> + status "Opening disk images ..."; + open_disk_images images cb | Read_directory (src, dir, cb) -> + status "Reading directory %s ..." dir; + let g = get_g () in let names, stats, links = with_mount_ro g src ( @@ -328,6 +377,8 @@ and execute_command = function fun ((name, stat), link) -> { dent_name = name; dent_stat = stat; dent_link = link } ) entries in + + status "Finished reading directory %s" dir; callback_if_not_discarded cb entries (* Expect to be connected, and return the current libvirt connection. *) @@ -448,9 +499,13 @@ and open_disk_images images cb = g#launch (); + status "Listing filesystems ..."; + (* Get list of filesystems. *) let fses = g#list_filesystems () in + status "Looking for operating systems ..."; + (* Perform inspection. This can fail, ignore errors. *) let roots = try Array.to_list (g#inspect_os ()) @@ -482,6 +537,8 @@ and open_disk_images images cb = insp_all_filesystems = fses; insp_oses = oses; } in + + status "Finished opening disk"; callback_if_not_discarded cb data (* guestfs_lstatlist has a "hidden" limit of the protocol message size. diff --git a/slave.mli b/slave.mli index a2725ea..2b08e04 100644 --- a/slave.mli +++ b/slave.mli @@ -174,6 +174,11 @@ val download_dir_find0 : ?fail:exn callback -> source -> string -> string -> uni file (a ASCII NUL-separated text file), and then calls the callback function. *) +val disk_usage : ?fail:exn callback -> source -> string -> int64 callback -> unit + (** [disk_usage src pathname cb] calculates the disk usage of + directory [pathname] and calls the callback with the answer + (size of {b kilobytes}). *) + val discard_command_queue : unit -> unit (** [discard_command_queue ()] discards any commands on the command queue. @@ -218,6 +223,12 @@ val set_idle_hook : unit callback -> unit the slave thread stops working on a command {i and} has no more commands left in the queue to work on. *) +val set_status_hook : string callback -> unit + (** Set the function in the main thread which is called to + update the status bar. The slave thread updates the + status bar when an operation starts or stops, keeping the + user informed of what is happening. *) + val set_progress_hook : (int64 * int64) callback -> unit (** Set the function in the main thread which is called whenever the slave thread receives a progress notification message diff --git a/window.ml b/window.ml index 5f3852a..ab52078 100644 --- a/window.ml +++ b/window.ml @@ -39,28 +39,18 @@ 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_vmcombo ws doms and populate_vmcombo ws doms = @@ -75,7 +65,6 @@ and populate_vmcombo ws 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) @@ -83,7 +72,6 @@ let rec open_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. *) @@ -91,7 +79,6 @@ and open_disk_images ws images = match images with | [] -> () | images -> - set_statusbar ws "Opening disks ..."; clear_view ws; Slave.discard_command_queue (); Slave.open_images images (when_opened_disk_images ws images) @@ -102,7 +89,6 @@ and when_opened_disk_images ws images data = | [] -> () | (image, _) :: _ -> debug "when_opened_disk_images callback"; - set_statusbar ws "Opened disk"; when_opened_common ws image data (* Common code for when_opened_domain/when_opened_disk_images. *) @@ -207,8 +193,6 @@ let rec open_main_window () = ) ); - Filetree.set_status_fn view (set_statusbar ws); - (* Return the window_state struct. *) ws diff --git a/window.mli b/window.mli index 2ebbeba..b2877bb 100644 --- a/window.mli +++ b/window.mli @@ -35,6 +35,11 @@ val throbber_idle : window_state -> unit -> unit thread) which are called whenever the throbber should be animated/busy or idle. *) +val set_statusbar : window_state -> string -> unit + (** This callback from the slave thread (invoked in the main thread) + updates the status bar when some slave operation starts or + stops. *) + val progress : window_state -> int64 * int64 -> unit (** This called whenever the progress bar should move. *) -- 1.8.3.1