From: Richard Jones Date: Wed, 16 Jun 2010 10:59:09 +0000 (+0100) Subject: Version 0.0.1 X-Git-Tag: 0.0.1^0 X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=385db03c92bcb0f161f810bb6335531cc2d14685;p=guestfs-browser.git Version 0.0.1 --- diff --git a/.gitignore b/.gitignore index b25c15b..76eda68 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,21 @@ *~ +*.cmi +*.cmo +*.cmx +*.o +.depend +Makefile +Makefile.in +aclocal.m4 +autom4te.cache +compile +config.h +config.h.in +config.log +config.ml +config.status +configure +guestfs-browser +install-sh +missing +stamp-h1 diff --git a/HACKING b/HACKING index 7a139bc..ab5f83a 100644 --- a/HACKING +++ b/HACKING @@ -22,6 +22,9 @@ In OCaml, a module such as 'Slave' is defined by its interface in 'slave.mli' (note lowercase first letter), and its implementation in 'slave.ml'. +In general terms, always start by reading the .mli file (if it exists) +in order to understand the module and before opening the .ml file. + Threads and messages -------------------- diff --git a/Makefile.am b/Makefile.am index 9e02e88..569d350 100644 --- a/Makefile.am +++ b/Makefile.am @@ -19,37 +19,71 @@ ACLOCAL_AMFLAGS = -I m4 EXTRA_DIST = HACKING Throbber.png Throbber.gif -CLEANFILES = *.cmi *.cmo *.cmx *.o guestfs-browser throbber.ml +CLEANFILES = *.cmi *.cmo *.cmx *.o guestfs-browser SOURCES = \ + cmdline.mli \ + cmdline.ml \ + config.ml \ + filetree.mli \ + filetree.ml \ main.ml \ slave.mli \ slave.ml \ throbber.ml \ utils.mli \ - utils.ml + utils.ml \ + window.mli \ + window.ml OBJECTS = \ - main.cmx \ - slave.cmx \ throbber.cmx \ - utils.cmx + config.cmx \ + utils.cmx \ + slave.cmx \ + filetree.cmx \ + cmdline.cmx \ + window.cmx \ + main.cmx bin_SCRIPTS = guestfs-browser -OCAMLOPTFLAGS = \ +OCAMLCFLAGS = \ + -g \ -warn-error A \ -thread \ -package libvirt,guestfs,lablgtk2,extlib,xml-light,threads +OCAMLOPTFLAGS = $(OCAMLCFLAGS) + guestfs-browser: $(OBJECTS) - ocamlfind ocamlopt $(OCAMLOPTFLAGS) \ + $(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) \ -predicates init,threads \ -linkpkg gtkThread.cmx \ $^ -o $@ +# This file is built. However gdk_pixbuf_mlsource requires X11 to +# run, which prevents this from being built in places where an X +# display is not available, such as on automated builders. So we'll +# bundle this file in with the tarball anyway. throbber.ml: Throbber.png Throbber.gif - gdk_pixbuf_mlsource --build-list \ + $(GDK_PIXBUF_MLSOURCE) --build-list \ static Throbber.png \ animation Throbber.gif \ > $@-t && mv $@-t $@ + +.mli.cmi: + $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -c $< -o $@ +.ml.cmo: + $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -c $< -o $@ +.ml.cmx: + $(OCAMLFIND) ocamlopt $(OCAMLCFLAGS) -c $< -o $@ + +depend: .depend + +.depend: $(wildcard *.mli) $(wildcard *.ml) + rm -f $@ $@-t + $(OCAMLFIND) ocamldep $^ > $@-t + mv $@-t $@ + +include .depend diff --git a/README b/README new file mode 100644 index 0000000..f37102f --- /dev/null +++ b/README @@ -0,0 +1,25 @@ +>>> This is alpha quality software. Read 'HACKING' and 'TODO'. <<< + +Guest filesystem browser +Copyright (C) 2010 Red Hat Inc. + +To compile from source, install the prerequisites (run the ./configure +script and it will tell you what's missing). + + autoreconf -i # if using the git version + ./configure + make + +We strongly suggest you run the program like this: + + ./guestfs-browser [--verbose] [--write] --connect qemu:///system +or: + ./guestfs-browser [--verbose] [--write] disk.img + +--verbose enables debug level messages and is recommended. + +--write enables writes to the filesystems and is *not* recommended. + +--connect tells the program which libvirt to connect to, and is +required at the moment if you want to use libvirt, because we have not +yet implemented the associated menu options. diff --git a/TODO b/TODO new file mode 100644 index 0000000..08f0aba --- /dev/null +++ b/TODO @@ -0,0 +1,3 @@ +The context menu does nothing at the moment. + +The menu items do nothing at the moment. diff --git a/cmdline.ml b/cmdline.ml new file mode 100644 index 0000000..43e0bf6 --- /dev/null +++ b/cmdline.ml @@ -0,0 +1,82 @@ +(* 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 new file mode 100644 index 0000000..79b411f --- /dev/null +++ b/cmdline.mli @@ -0,0 +1,30 @@ +(* 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/config.ml.in b/config.ml.in new file mode 100644 index 0000000..667c00d --- /dev/null +++ b/config.ml.in @@ -0,0 +1,20 @@ +(* Guestfs Browser. + * Copyright (C) 2010 Red Hat Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + *) + +let package = "@PACKAGE_NAME@" +let version = "@PACKAGE_VERSION@" diff --git a/configure.ac b/configure.ac index 3060420..8f45e75 100644 --- a/configure.ac +++ b/configure.ac @@ -46,6 +46,29 @@ if test "$OCAML_PKG_lablgtk2" = "no"; then AC_MSG_ERROR([Please install OCaml module 'lablgtk2'.]) fi +AC_CHECK_OCAML_PKG([libvirt]) +if test "$OCAML_PKG_libvirt" = "no"; then + AC_MSG_ERROR([Please install OCaml module 'libvirt'.]) +fi + +AC_CHECK_OCAML_PKG([guestfs]) +if test "$OCAML_PKG_guestfs" = "no"; then + AC_MSG_ERROR([Please install OCaml module 'guestfs'.]) +fi + +AC_CHECK_OCAML_PKG([xml-light]) +if test "$OCAML_PKG_xml_light" = "no"; then + AC_MSG_ERROR([Please install OCaml module 'xml-light'.]) +fi + +AC_CHECK_OCAML_PKG([extlib]) +if test "$OCAML_PKG_extlib" = "no"; then + AC_MSG_ERROR([Please install OCaml module 'extlib'.]) +fi + +dnl Check for gdk_pixbuf_mlsource program. +AC_PATH_PROGS([GDK_PIXBUF_MLSOURCE], [gdk_pixbuf_mlsource]) + AC_CONFIG_HEADERS([config.h]) -AC_CONFIG_FILES([Makefile]) +AC_CONFIG_FILES([Makefile config.ml]) AC_OUTPUT diff --git a/filetree.ml b/filetree.ml new file mode 100644 index 0000000..1969cc7 --- /dev/null +++ b/filetree.ml @@ -0,0 +1,442 @@ +(* Guestfs Browser. + * Copyright (C) 2010 Red Hat Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + *) + +open ExtList +open ExtString +open Printf + +open Utils + +module G = Guestfs + +let unique = let i = ref 0 in fun () -> incr i; !i + +(* The type of the hidden column used to implement on-demand loading. + * We are going to store these in the model as simple ints because that + * is easier on the GC. Don't change these numbers! + *) +let isFile = 0 (* it's not a directory, there are no children *) +let dirNotStarted = 1 (* user has not tried to open this *) +let dirLoading = 2 (* user tried to open it, still loading *) +let isDir = 3 (* we've loaded the children of this directory *) +let loading = 4 (* this row contains the "Loading ..." message *) + +let rec filetree dev rw = + let view = GTree.view () in + (*view#set_rules_hint true;*) + view#selection#set_mode `MULTIPLE; + + (* Hash of index numbers -> other data. We do this because it's + * more efficient for the GC compared to storing OCaml objects + * directly in the rows. + *) + let hash = Hashtbl.create 1023 in + + (* The columns stored in each row. The hidden [state_col] column + * stores the current state of the row, and is used to implement + * on-demand loading. The hidden [index_col] column is an index into + * the hash table that records everything else about this row + * (filename, file stat, etc). The other display columns, eg. + * [name_col] contain Pango markup and thus have to be escaped. + *) + let cols = new GTree.column_list in + (* Hidden: *) + let state_col = cols#add Gobject.Data.int in + let index_col = cols#add Gobject.Data.int in + (* Displayed: *) + let mode_col = cols#add Gobject.Data.string in + let name_col = cols#add Gobject.Data.string in + let size_col = cols#add Gobject.Data.int64 in + let date_col = cols#add Gobject.Data.string in + let link_col = cols#add Gobject.Data.string in + + let model = GTree.tree_store cols in + view#set_model (Some (model :> GTree.model)); + + let renderer = GTree.cell_renderer_text [], ["markup", mode_col] in + let mode_view = GTree.view_column ~title:"Permissions" ~renderer () in + ignore (view#append_column mode_view); + + let renderer = GTree.cell_renderer_text [], ["markup", name_col] in + let name_view = GTree.view_column ~title:"Filename" ~renderer () in + ignore (view#append_column name_view); + + let renderer = GTree.cell_renderer_text [], ["text", size_col] in + let size_view = GTree.view_column ~title:"Size" ~renderer () in + ignore (view#append_column size_view); + + let renderer = GTree.cell_renderer_text [], ["markup", date_col] in + let date_view = GTree.view_column ~title:"Date" ~renderer () in + ignore (view#append_column date_view); + + let renderer = GTree.cell_renderer_text [], ["markup", link_col] in + let link_view = GTree.view_column ~title:"Link" ~renderer () in + ignore (view#append_column link_view); + + let tree = + model, view, hash, dev, rw, + (state_col, index_col, mode_col, name_col, size_col, date_col, + link_col) in + + (* Create the root directory entry, then expand it which will force + * it to be loaded (asynchronously). + * XXX Should stat "/" + *) + let root = model#append () in + add_directory_row tree root "/" None; + view#expand_row (model#get_path root); + + ignore (view#event#connect#button_press ~callback:(button_press tree)); + (*ignore (view#event#connect#popup_menu ~callback);*) + + view + +(* Add an "embryonic" directory to the tree store. This contains a + * dummy entry (as explained + * http://mail.gnome.org/archives/gtk-app-devel-list/2003-May/msg00241.html) + * and when the user opens it, it triggers the real directory to be + * read. + *) +and add_directory_row tree row filename direntry = + let model, view, hash, _, _, + (state_col, index_col, mode_col, name_col, size_col, date_col, + link_col) + = tree in + + model#set ~row ~column:state_col dirNotStarted; + model#set ~row ~column:index_col (-1); + model#set ~row ~column:name_col (markup_of_name filename); + (match direntry with + | None -> () + | Some direntry -> + let index = unique () in + Hashtbl.add hash index direntry; + model#set ~row ~column:index_col index; + let stat = direntry.Slave.dent_stat in + model#set ~row ~column:mode_col (markup_of_mode stat.G.mode); + model#set ~row ~column:size_col stat.G.size; + model#set ~row ~column:date_col (markup_of_date stat.G.mtime)); + + let placeholder = model#append ~parent:row () in + model#set ~row:placeholder ~column:state_col loading; + model#set ~row:placeholder ~column:index_col (-1); + model#set ~row:placeholder ~column:name_col "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 _ -> ()); + + (* The original directory entry has now been loaded, so + * update its state. + *) + model#set ~row ~column:state_col isDir + +(* Get the actual full pathname of a row. *) +and get_pathname tree row = + let model, _, _, _, _, _ = tree in + + match model#iter_parent row with + | None -> "/" + | Some parent -> + match get_direntry_of_row tree row with + | Some { Slave.dent_name = name } -> + let pname = get_pathname tree parent in + if pname = "/" then "/" ^ name else pname ^ "/" ^ name + | None -> + assert false + +(* Get the directory entry from a row (contains the stat(2) results etc). + * Some rows don't have the required information (eg. placeholder rows + * and currently the root directory) and for them we return [None]. + *) +and get_direntry_of_row tree row = + let model, _, hash, _, _, (_, index_col, _, _, _, _, _) = tree in + let index = model#get ~row ~column:index_col in + try Some (Hashtbl.find hash index) + with Not_found -> None + +(* XXX No binding for g_markup_escape in lablgtk2. *) +and markup_escape name = + let f = function + | '&' -> "&" | '<' -> "<" | '>' -> ">" + | c -> String.make 1 c + in + String.replace_chars f name + +(* Mark up a filename for the name_col column. *) +and markup_of_name name = + (* First, protect against any markup in the name. *) + let name = markup_escape name in + name + +(* Mark up symbolic links. *) +and markup_of_link link = + let link = markup_escape link in + if link <> "" then utf8_rarrow ^ " " ^ link else "" + +(* Mark up mode. *) +and markup_of_mode mode = + let c = + if is_socket mode then 's' + else if is_symlink mode then 'l' + else if is_regular_file mode then '-' + else if is_block mode then 'b' + else if is_directory mode then 'd' + else if is_char mode then 'c' + else if is_fifo mode then 'p' else '?' in + let ru = if test_bit 0o400L mode then 'r' else '-' in + let wu = if test_bit 0o200L mode then 'w' else '-' in + let xu = if test_bit 0o100L mode then 'x' else '-' in + let rg = if test_bit 0o40L mode then 'r' else '-' in + let wg = if test_bit 0o20L mode then 'w' else '-' in + let xg = if test_bit 0o10L mode then 'x' else '-' in + let ro = if test_bit 0o4L mode then 'r' else '-' in + let wo = if test_bit 0o2L mode then 'w' else '-' in + let xo = if test_bit 0o1L mode then 'x' else '-' in + let str = sprintf "%c%c%c%c%c%c%c%c%c%c" c ru wu xu rg wg xg ro wo xo in + + let suid = test_bit 0o4000L mode in + let sgid = test_bit 0o2000L mode in + let svtx = test_bit 0o1000L mode in + if suid then str.[3] <- 's'; + if sgid then str.[6] <- 's'; + if svtx then str.[9] <- 't'; + + "" ^ str ^ "" + +(* File type tests. *) +and file_type mask mode = Int64.logand mode 0o170000L = mask + +and is_socket mode = file_type 0o140000L mode +and is_symlink mode = file_type 0o120000L mode +and is_regular_file mode = file_type 0o100000L mode +and is_block mode = file_type 0o060000L mode +and is_directory mode = file_type 0o040000L mode +and is_char mode = file_type 0o020000L mode +and is_fifo mode = file_type 0o010000L mode + +and test_bit mask mode = Int64.logand mode mask = mask + +(* Mark up dates. *) +and markup_of_date time = + let time = Int64.to_float time in + let tm = Unix.localtime time in + sprintf "%04d-%02d-%02d %02d:%02d:%02d" + (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday + tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec + +(* Handle mouse button press on the selected row. This opens the + * pop-up context menu. + * http://scentric.net/tutorial/sec-selections-context-menus.html + *) +and button_press tree ev = + let button = GdkEvent.Button.button ev in + let x = int_of_float (GdkEvent.Button.x ev) in + let y = int_of_float (GdkEvent.Button.y ev) in + let time = GdkEvent.Button.time ev in + + (* Right button for opening the context menu. *) + if button = 3 then ( + let model, view, hash, _, _, (_, index_col, _, _, _, _, _) = tree in + + (* If no row is selected, select the row under the mouse. *) + let paths = + let sel = view#selection in + if sel#count_selected_rows < 1 then ( + match view#get_path_at_pos ~x ~y with + | None -> [] + | Some (path, _, _, _) -> + sel#unselect_all (); + sel#select_path path; + [path] + ) else + sel#get_selected_rows (* actually returns paths *) in + + (* Ignore paths that don't contain index fields, and get the + * direntry for the others. Currently this causes the root + * directory to be ignored because we don't have stat information + * for it (XXX). + *) + let paths = + List.filter_map ( + fun path -> + let row = model#get_iter path in + match get_direntry_of_row tree row with + | None -> None + | Some direntry -> Some (path, direntry) + ) paths in + + (* Choose the menu and menu options according to the number of + * selected rows and what is selected. + *) + let menu = + try + (match paths with + | [] -> None + | [path, direntry] -> (* Single selection. *) + (* What object is selected? *) + let stat = direntry.Slave.dent_stat in + let mode = stat.G.mode in + if is_directory mode then + Some (make_context_menu tree ~dir:true ~file:false paths) + else if is_regular_file mode then + Some (make_context_menu tree ~dir:false ~file:true paths) + else (* not directory, not regular file *) + Some (make_context_menu tree ~dir:false ~file:false paths) + | paths -> (* Multiple selection. *) + let dir = List.for_all ( + fun (_, { Slave.dent_stat = stat }) -> + is_directory stat.G.mode + ) paths in + let file = List.for_all ( + fun (_, { Slave.dent_stat = stat }) -> + is_regular_file stat.G.mode + ) paths in + Some (make_context_menu tree ~dir ~file paths) + ) + with Not_found -> None + in + (match menu with + | None -> () + | Some menu -> + menu#popup ~button ~time; + ); + + (* Return true so no other handler will run. *) + true + ) else + (* Defer to other handlers. *) + false + +(* Make a context menu for file(s) and directory(s). ~file is true is + * they are all regular files, ~dir is true if they are all + * directories. If neither is set, then it can be a single selection + * of a non-file non-directory, or it can be a mixed multiple + * selection. + *) +and make_context_menu tree ~dir ~file paths = + let _, _, _, _, rw, _ = tree in + let n = List.length paths in + + debug "make_context_menu dir %b file %b n %d" dir file n; + + let menu = GMenu.menu () in + let factory = new GMenu.factory menu in + + (* Open appears first, and unconditionally. This is just to catch + * the case where nothing below matches, and we want to display + * _something_. Open is not necessarily useful ... + *) + ignore (factory#add_item "Open"); + ignore (factory#add_separator ()); + + if dir && n = 1 then ( + ignore (factory#add_item "Disk usage ..."); + ignore (factory#add_item "Export as an archive (tar etc) ..."); + ignore (factory#add_item "Export checksums ..."); + ignore (factory#add_item "Export as a list of files ..."); + ); + + if file then + ignore (factory#add_item "Determine file type ..."); + + if n = 1 then + ignore (factory#add_item "View permissions ..."); + + (* Write operations go below the separator. *) + (match rw with + | Slave.RO -> () + | Slave.RW -> + ignore (factory#add_separator ()); + + if dir && n = 1 then ( + ignore (factory#add_item "New file ..."); + ignore (factory#add_item "New subdirectory ..."); + ignore (factory#add_item "Import an archive here ..."); + ); + + if file then ( + ignore (factory#add_item "Touch file"); + ignore (factory#add_item "Edit file"); + ); + + if n = 1 then + ignore (factory#add_item "Edit permissions ..."); + + ignore (factory#add_item "Delete") + ); + + menu diff --git a/filetree.mli b/filetree.mli new file mode 100644 index 0000000..7321a4f --- /dev/null +++ b/filetree.mli @@ -0,0 +1,33 @@ +(* Guestfs Browser. + * Copyright (C) 2010 Red Hat Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + *) + +(** Tree model for displaying files in the guest filesystem. + + The model reads files and directories on demand so that we don't + have to read the whole thing in at the beginning. + + Originally this was written as a custom tree model, but we + couldn't get that to work. Instead we use something similar + to this trick: + http://mail.gnome.org/archives/gtk-app-devel-list/2003-May/msg00241.html *) + +val filetree : string -> Slave.rw_flag -> GTree.view + (** [filetree dev rw] creates a new filetree widget. + + [dev] is the device. + [rw] is the RO|RW flag. *) diff --git a/main.ml b/main.ml index a823aa5..9a72113 100644 --- a/main.ml +++ b/main.ml @@ -16,68 +16,38 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Utils - -(* Display state. *) -type display_state = { - window : GWindow.window; - throbber_busy : unit -> unit; - throbber_idle : unit -> unit; -} - -let open_main_window () = - let title = "Guest Filesystem Browser" in - let window = GWindow.window ~width:800 ~height:600 ~title () in - let vbox = GPack.vbox ~packing:window#add () in - - (* Do the menus. *) - let menubar = GMenu.menu_bar ~packing:vbox#pack () in - let factory = new GMenu.factory menubar in - let accel_group = factory#accel_group in - let connect_menu = factory#add_submenu "_Connect" in - - let factory = new GMenu.factory connect_menu ~accel_group in - let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in +open Printf - (* Quit. *) - let quit _ = GMain.quit (); false in - ignore (window#connect#destroy ~callback:GMain.quit); - ignore (window#event#connect#delete ~callback:quit); - ignore (quit_item#connect#activate - ~callback:(fun () -> ignore (quit ()); ())); - - (* Top status area. *) - let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in - ignore (GMisc.label ~text:"Guest: " ~packing:hbox#pack ()); +open Utils - (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *) - let static = Throbber.static () in - (*let animation = Throbber.animation () in*) - let throbber = - GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in - let throbber_busy () = - (*throbber#set_pixbuf animation*) - (* Workaround because no binding for GdkPixbufAnimation: *) - let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in - throbber#set_file file - and throbber_idle () = - throbber#set_pixbuf static - in +module G = Guestfs - window#show (); - window#add_accel_group accel_group; +(* Main. *) +let () = + let cli_request = Cmdline.command_line () in - (* display_state which is threaded through all the other callbacks, - * allowing callbacks to update the window. + (* If we're in verbose mode, print some debug information which + * could be useful in bug reports. *) - { window = window; - throbber_busy = throbber_busy; throbber_idle = throbber_idle } - -let () = - let ds = open_main_window () in - Slave.set_failure_hook (failure ds); - Slave.set_busy_hook ds.throbber_busy; - Slave.set_idle_hook ds.throbber_idle; + if verbose () then ( + debug "%s %s" Config.package Config.version; + let v = fst (Libvirt.get_version ()) in + debug "libvirt %d.%d.%d" + (v / 1_000_000) ((v / 1_000) mod 1_000) (v mod 1_000); + let g = G.create () in + let v = G.version g in + debug "libguestfs %Ld.%Ld.%Ld%s" + v.G.major v.G.minor v.G.release v.G.extra; + G.close g; + ); + + let ds = Window.open_main_window () in + Slave.set_failure_hook (Window.failure ds); + Slave.set_busy_hook ds.Window.throbber_busy; + Slave.set_idle_hook ds.Window.throbber_idle; + + (* What did the user request on the command line? *) + Window.run_cli_request ds cli_request; (* Run the main display thread. When this returns, the application * has been closed. diff --git a/slave.ml b/slave.ml index 1017dd8..d1cff80 100644 --- a/slave.ml +++ b/slave.ml @@ -16,6 +16,8 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open ExtList +open Printf open Utils module C = Libvirt.Connect @@ -32,6 +34,10 @@ 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 and domain = { dom_id : int; @@ -39,6 +45,35 @@ and domain = { dom_state : D.state; } +and rw_flag = RO | RW + +and volume = { + vol_device : string; + vol_type : string; + vol_label : string; + vol_uuid : string; + vol_statvfs : Guestfs.statvfs; +} + +and direntry = { + dent_name : string; + dent_stat : Guestfs.stat; + dent_link : string; +} + +let string_of_command = function + | Exit_thread -> "Exit_thread" + | Connect (Some name, _) -> sprintf "Connect %s" name + | Connect (None, _) -> "Connect NULL" + | Get_domains _ -> "Get_domains" + | Open_domain (name, _) -> sprintf "Open_domain %s" name + | Open_images (images, _) -> + sprintf "Open_images [%s]" (String.concat "; " images) + | Get_volumes _ -> "Get_volumes" + | Read_directory (dev, dir, _) -> sprintf "Read_directory %s %s" dev dir + +let string_of_rw_flag = function RO -> "RO" | RW -> "RW" + let no_callback _ = () let failure_hook = ref (fun _ -> ()) @@ -68,7 +103,7 @@ let q_cond = Cond.create () (* Send a command message to the slave thread. *) let send_to_slave cmd = - debug "sending message %s to slave thread ..." (string_of_command cmd) + debug "sending message %s to slave thread ..." (string_of_command cmd); with_lock q_lock ( fun () -> Q.push cmd q; @@ -79,12 +114,32 @@ let discard_command_queue () = with_lock q_lock (fun () -> Q.clear q) let connect uri cb = send_to_slave (Connect (uri, cb)) let get_domains cb = send_to_slave (Get_domains cb) +let get_volumes cb = send_to_slave (Get_volumes cb) +let open_domain name cb = send_to_slave (Open_domain (name, cb)) +let open_images images cb = send_to_slave (Open_images (images, cb)) +let read_directory dev dir cb = send_to_slave (Read_directory (dev, dir, cb)) (*----- Slave thread starts here -----*) (* Set this to true to exit the thread. *) let quit = ref false +(* Handles. These are not protected by locks because only the slave + * thread has access to them. + *) +let conn = ref None +let g = ref None + +(* Call 'f ()' with 'dev' mounted read-only. Ensure that everything + * is unmounted even if an exception is thrown. + *) +let with_mount_ro g dev (f : unit -> 'a) : 'a = + Std.finally (fun () -> G.umount_all g) ( + fun () -> + G.mount_ro g dev "/"; + f () + ) () + let rec loop () = (* Get the next command. *) let cmd = @@ -96,57 +151,216 @@ let rec loop () = Q.pop q ) in - debug "slave thread processing command %s ..." (string_of_command cmd); + debug "thread id %d: slave processing command %s ..." + (Thread.id (Thread.self ())) (string_of_command cmd); (try - call_callback !busy_hook (); + GtkThread.async !busy_hook (); execute_command cmd; - call_callback !idle_hook (); with exn -> (* If a command fails, clear the command queue and run the * failure hook in the main thread. *) - call_callback !idle_hook (); discard_command_queue (); - call_callback !failure_hook exn + GtkThread.async !failure_hook exn ); + (* If there are no more commands in the queue, run the idle hook. *) + let r = with_lock q_lock (fun () -> Q.is_empty q) in + if r then GtkThread.async !idle_hook (); + if !quit then Thread.exit (); loop () and execute_command = function | Exit_thread -> quit := true; - disconnect_all () + close_all () - | Connect (uri, cb) -> - disconnect_all (); - conn := Some (C.connect_readonly ?uri ()); - call_callback cb () + | Connect (name, cb) -> + close_all (); + conn := Some (C.connect_readonly ?name ()); + GtkThread.async cb () | Get_domains cb -> let conn = get_conn () in let doms = D.get_domains conn [D.ListAll] in let doms = List.map ( fun d -> - D.get_id d, D.get_name d, (D.get_info d).D.state + { dom_id = D.get_id d; + dom_name = D.get_name d; + dom_state = (D.get_info d).D.state } ) doms in - call_callback cb doms + let cmp { dom_name = n1 } { dom_name = n2 } = compare n1 n2 in + let doms = List.sort ~cmp doms in + GtkThread.async cb doms + + | Open_domain (name, cb) -> + let conn = get_conn () in + let dom = D.lookup_by_name conn name in + (* Only permit writes to shut off domains. This isn't foolproof + * since the user could start up the domain while we're running, + * which would cause disk corruption. Until we can negotiate a + * feasible locking scheme with libvirt/qemu, this is the best we + * can do. + *) + let rw = write_flag () && (D.get_info dom).D.state = D.InfoShutoff in + let rw = if rw then RW else RO in + let xml = D.get_xml_desc dom in + let images = get_disk_images_from_xml xml in + open_disk_images rw images cb + + | Open_images (images, cb) -> + let rw = write_flag () in + let rw = if rw then RW else RO in + open_disk_images rw images cb -(* Call a callback function or hook in the main thread. *) -and call_callback cb arg = - GtkThread.async cb arg + | Get_volumes cb -> + let g = get_g () in + (* Devices which directly contain filesystems (RHBZ#590167). *) + let devices = G.list_devices g in + Array.iter (if_mountable_vol g cb) devices; + let partitions = G.list_partitions g in + Array.iter (if_mountable_vol g cb) partitions; + let lvs = G.lvs g in + Array.iter (if_mountable_vol g cb) lvs + + | Read_directory (dev, dir, cb) -> + let g = get_g () in + let names, stats, links = + with_mount_ro g dev ( + fun () -> + let names = G.ls g dir in (* sorted and without . and .. *) + let names = Array.to_list names in + let stats = lstatlist_wrapper g dir names in + let links = readlinklist_wrapper g dir names in + names, stats, links + ) in + assert ( + let n = List.length names in + n = List.length stats && n = List.length links + ); + let entries = List.combine (List.combine names stats) links in + let entries = List.map ( + fun ((name, stat), link) -> + { dent_name = name; dent_stat = stat; dent_link = link } + ) entries in + GtkThread.async cb entries (* Expect to be connected, and return the current libvirt connection. *) -let get_conn () = +and get_conn () = match !conn with | Some conn -> conn | None -> failwith "not connected to libvirt" +and get_g () = + match !g with + | Some g -> g + | None -> failwith "no domain or disk image is open" + (* Close all libvirt and libguestfs handles. *) -and disconnect_all () = +and close_all () = (match !conn with Some conn -> C.close conn | None -> ()); - conn := None + conn := None; + close_g () + +and close_g () = + (match !g with Some g -> G.close g | None -> ()); + g := None + +and get_disk_images_from_xml xml = + let xml = Xml.parse_string xml in + let devices = + match xml with + | Xml.Element ("domain", _, children) -> + let devices = + List.filter_map ( + function + | Xml.Element ("devices", _, devices) -> Some devices + | _ -> None + ) children in + List.concat devices + | _ -> + failwith "get_xml_desc didn't return " in + let rec source_of = 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 + in + let blkdevs = + List.filter_map ( + function + | Xml.Element ("disk", _, children) -> source_of children + | _ -> None + ) devices in + blkdevs + +(* The common code for Open_domain and Open_images which opens the + * libguestfs handle, adds the disks, and launches the appliance. + *) +and open_disk_images rw images cb = + debug "opening disk image [%s] in %s mode" + (String.concat "; " images) (string_of_rw_flag rw); + + close_g (); + let g' = G.create () in + g := Some g'; + let g = g' in + + G.set_verbose g (verbose ()); + + let add = (match rw with RO -> G.add_drive_ro | RW -> G.add_drive) g in + List.iter add images; + + G.launch g; + GtkThread.async cb rw + +(* This is the common function implementing Get_volumes. Test if a + * particular partition contains a mountable filesystem. We do this + * simply by trying to mount it. If it does, get the rest of the + * information for the volume, and call the callback. + *) +and if_mountable_vol g cb dev = + try + with_mount_ro g dev ( + fun () -> + let vol_type = G.vfs_type g dev in + let vol_label = G.vfs_label g dev in + let vol_uuid = G.vfs_uuid g dev in + let vol_statvfs = G.statvfs g "/" in + let vol = { + vol_device = dev; vol_type = vol_type; vol_label = vol_label; + vol_uuid = vol_uuid; vol_statvfs = vol_statvfs + } in + GtkThread.async cb vol + ) + with G.Error msg -> + debug "is_mountable: %s: not mountable because: %s" dev msg + +(* guestfs_lstatlist has a "hidden" limit of the protocol message size. + * Call this function, but split the list of names into chunks. + *) +and lstatlist_wrapper g dir = function + | [] -> [] + | names -> + let names', names = List.take 1000 names, List.drop 1000 names in + let xs = G.lstatlist g dir (Array.of_list names') in + let xs = Array.to_list xs in + xs @ lstatlist_wrapper g dir names + +(* Same as above for guestfs_readlinklist. *) +and readlinklist_wrapper g dir = function + | [] -> [] + | names -> + let names', names = List.take 1000 names, List.drop 1000 names in + let xs = G.readlinklist g dir (Array.of_list names') in + let xs = Array.to_list xs in + xs @ readlinklist_wrapper g dir names (* Start up one slave thread. *) let slave_thread = Thread.create loop () diff --git a/slave.mli b/slave.mli index 994890f..f60f835 100644 --- a/slave.mli +++ b/slave.mli @@ -51,6 +51,7 @@ val connect : string option -> unit callback -> unit doesn't make sense to use remote URIs. *) type domain = { + dom_id : int; dom_name : string; dom_state : Libvirt.Domain.state; } @@ -58,7 +59,7 @@ type domain = { Note that [dom_state] is the state of the domain and should control whether we are allowed to write to the domain's - filesystem (disallowed if [dom_state] is [InfoRunning]). *) + filesystem (disallowed if [dom_state] is not [InfoShutoff]). *) val get_domains : domain list callback -> unit (** [get_domains cb] sends the [Get_domains] message to the @@ -69,6 +70,67 @@ val get_domains : domain list callback -> unit [cb] is called in the main thread with the list of domains. See also the {!domain} type. *) +type rw_flag = RO | RW + (** This flag is passed to open callbacks to indicate whether + we could open the disks read-only ([RO]) or read-write ([RW]). *) + +val open_domain : string -> rw_flag callback -> unit + (** [open_domain name cb] sends the [Open_domain] message to the + slave thread. + + This causes the slave thread to retrieve the list of + block devices for the libvirt domain [name], create a + libguestfs handle, add those block devices, and launch + the handle. If this is successful, then [cb] is called + in the main thread. + + If the domain is live then the disks are opened read only, + else they are opened read write if write_flag is true. + The [rw_flag] is passed into the callback accordingly. + + The slave thread must be connected to libvirt (see {!connect}) + else this command will fail. *) + +val open_images : string list -> rw_flag callback -> unit + (** [open_images images cb] is like {!open_domain} except + that it opens local disk image(s) directly. *) + +type volume = { + vol_device : string; + vol_type : string; + vol_label : string; + vol_uuid : string; + vol_statvfs : Guestfs.statvfs; +} + (** The volume structure which is passed to the {!get_volumes} callback. *) + +val get_volumes : volume callback -> unit + (** [get_volumes cb] sends the [Get_volumes] message to the + slave thread. + + This causes the slave thread to examine all partitions, LVs + etc within the current disk image, and for each that contains + a mountable filesystem, [cb] is called. (Note [cb] can be + called multiple times). *) + +type direntry = { + dent_name : string; (** Basename in directory. *) + dent_stat : Guestfs.stat; (** stat(2) for this entry. *) + dent_link : string; (** (for symlinks only) readlink(2). *) +} + +val read_directory : string -> string -> direntry list callback -> unit + (** [read_directory dev dir cb] sends the [Read_directory] message + to the slave thread. + + This causes the slave thread to read the contents of the + directory [dir] from volume [dev], and call [cb] with the + complete result. If [dir] is not a directory then this + is an error. + + Note that [.] and [..] entries are not included in the result, + and the list is sorted on the [filename] field. *) + val discard_command_queue : unit -> unit (** [discard_command_queue ()] discards any commands on the command queue. The currently running command is not (and can not be) diff --git a/throbber.ml b/throbber.ml new file mode 100644 index 0000000..d9403f2 --- /dev/null +++ b/throbber.ml @@ -0,0 +1,48 @@ + +let static_data = "\ +\132\149\166\190\000\000\001\113\000\000\000\001\000\000\000\003\000\000\000\003\ +\018\071\100\107\080\105\120\098\117\102\047\050\046\048\047\000\000\000\001\093\ +\071\100\107\080\000\000\001\093\002\001\000\002\000\000\000\080\000\000\000\020\ +\000\000\000\020\157\000\000\000\000\130\178\178\178\255\145\000\000\000\000\132\ +\178\178\178\255\140\000\000\000\000\130\178\178\178\255\130\000\000\000\000\132\ +\178\178\178\255\130\000\000\000\000\130\178\178\178\255\135\000\000\000\000\132\ +\178\178\178\255\130\000\000\000\000\130\178\178\178\255\130\000\000\000\000\132\ +\178\178\178\255\134\000\000\000\000\132\178\178\178\255\134\000\000\000\000\132\ +\178\178\178\255\135\000\000\000\000\130\178\178\178\255\136\000\000\000\000\130\ +\178\178\178\255\154\000\000\000\000\130\178\178\178\255\140\000\000\000\000\130\ +\178\178\178\255\131\000\000\000\000\132\178\178\178\255\138\000\000\000\000\132\ +\178\178\178\255\130\000\000\000\000\132\178\178\178\255\138\000\000\000\000\132\ +\178\178\178\255\131\000\000\000\000\130\178\178\178\255\140\000\000\000\000\130\ +\178\178\178\255\154\000\000\000\000\130\178\178\178\255\136\000\000\000\000\130\ +\178\178\178\255\135\000\000\000\000\132\178\178\178\255\134\000\000\000\000\132\ +\178\178\178\255\134\000\000\000\000\132\178\178\178\255\130\000\000\000\000\130\ +\178\178\178\255\130\000\000\000\000\132\178\178\178\255\135\000\000\000\000\130\ +\178\178\178\255\130\000\000\000\000\132\178\178\178\255\130\000\000\000\000\130\ +\178\178\178\255\140\000\000\000\000\132\178\178\178\255\145\000\000\000\000\130\ +\178\178\178\255\157\000\000\000\000" + +let static () : GdkPixbuf.pixbuf = Marshal.from_string static_data 0 + +let animation_data = "\ +\132\149\166\190\000\000\001\113\000\000\000\001\000\000\000\003\000\000\000\003\ +\018\071\100\107\080\105\120\098\117\102\047\050\046\048\047\000\000\000\001\093\ +\071\100\107\080\000\000\001\093\002\001\000\002\000\000\000\080\000\000\000\020\ +\000\000\000\020\157\255\255\255\000\130\000\000\000\255\145\255\255\255\000\132\ +\000\000\000\255\140\255\255\255\000\130\026\026\026\255\130\255\255\255\000\132\ +\000\000\000\255\130\255\255\255\000\130\178\178\178\255\135\255\255\255\000\132\ +\026\026\026\255\130\255\255\255\000\130\000\000\000\255\130\255\255\255\000\132\ +\178\178\178\255\134\255\255\255\000\132\026\026\026\255\134\255\255\255\000\132\ +\178\178\178\255\135\255\255\255\000\130\026\026\026\255\136\255\255\255\000\130\ +\178\178\178\255\154\255\255\255\000\130\051\051\051\255\140\255\255\255\000\130\ +\153\153\153\255\131\255\255\255\000\132\051\051\051\255\138\255\255\255\000\132\ +\153\153\153\255\130\255\255\255\000\132\051\051\051\255\138\255\255\255\000\132\ +\153\153\153\255\131\255\255\255\000\130\051\051\051\255\140\255\255\255\000\130\ +\153\153\153\255\154\255\255\255\000\130\076\076\076\255\136\255\255\255\000\130\ +\128\128\128\255\135\255\255\255\000\132\076\076\076\255\134\255\255\255\000\132\ +\128\128\128\255\134\255\255\255\000\132\076\076\076\255\130\255\255\255\000\130\ +\102\102\102\255\130\255\255\255\000\132\128\128\128\255\135\255\255\255\000\130\ +\076\076\076\255\130\255\255\255\000\132\102\102\102\255\130\255\255\255\000\130\ +\128\128\128\255\140\255\255\255\000\132\102\102\102\255\145\255\255\255\000\130\ +\102\102\102\255\157\255\255\255\000" + +let animation () : GdkPixbuf.pixbuf = Marshal.from_string animation_data 0 diff --git a/utils.ml b/utils.ml index 8f7ce3a..a3eca86 100644 --- a/utils.ml +++ b/utils.ml @@ -16,17 +16,47 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -type ('a, 'b) choice = Either of 'a | Or of 'b +open Printf -let verbose = ref true (* XXX settable *) +let (+^) = Int64.add +let (-^) = Int64.sub +let ( *^ ) = Int64.mul +let (/^) = Int64.div + +type ('a, 'b) either = Left of 'a | Right of 'b + +let verbose = ref false +let set_verbose_flag () = verbose := true +let verbose () = !verbose + +let write_flag = ref false +let set_write_flag () = write_flag := true +let write_flag () = !write_flag let debug fs = - let f str = if !verbose then (prerr_string str; prerr_newline ()) in + let f str = + if verbose () then ( + prerr_string Config.package; + prerr_string ": "; + prerr_string str; + prerr_newline () + ) + in ksprintf f fs let failwith fs = let f str = - if !verbose then (prerr_string str; prerr_newline ()); + if verbose () then (prerr_string str; prerr_newline ()); raise (Failure str) in ksprintf f fs + +let utf8_rarrow = "\xe2\x86\x92" + +let human_size_1k i = + if i < 1024L then + sprintf "%LdK" i + else if i < 1024L *^ 1024L then + sprintf "%.1fM" (Int64.to_float i /. 1024.) + else + sprintf "%.1fG" (Int64.to_float i /. 1024. /. 1024.) diff --git a/utils.mli b/utils.mli index f2a00db..0df3a43 100644 --- a/utils.mli +++ b/utils.mli @@ -18,18 +18,37 @@ (** General-purpose utility code used everywhere. *) +val (+^) : int64 -> int64 -> int64 +val (-^) : int64 -> int64 -> int64 +val ( *^ ) : int64 -> int64 -> int64 +val (/^) : int64 -> int64 -> int64 + (** Int64 arithmetic operators. *) + type ('a, 'b) either = Left of 'a | Right of 'b (** A value which is either an ['a] or a ['b], just like Haskell's "Either" type. *) -val verbose : bool ref +val verbose : unit -> bool +val set_verbose_flag : unit -> unit (** If this contains [true] then {!debug} will send debugging - messages to stderr, else debugging messages are dropped. *) + messages to stderr, else debugging messages are dropped. + + This is set through the --verbose command line option. *) + +val write_flag : unit -> bool +val set_write_flag : unit -> unit + (** Writes are prevented unless the user sets this to [true] + through the command line option --write. *) -val debug : ('a, out_channel, unit) format -> 'a +val debug : ('a, unit, string, unit) format4 -> 'a (** A printf-like function for writing debugging messages. *) -val failwith : ('a, out_channel, unit) format -> 'a +val failwith : ('a, unit, string, 'b) format4 -> 'a (** Replacement for standard OCaml [failwith] function. This can take a printf-like argument list, and also logs errors on stderr when verbose is enabled. *) + +val utf8_rarrow : string (** UTF-8 RIGHTWARDS ARROW *) + +val human_size_1k : int64 -> string + (** Convert a number (of 1K blocks) into a human readable string. *) diff --git a/window.ml b/window.ml new file mode 100644 index 0000000..a5116fc --- /dev/null +++ b/window.ml @@ -0,0 +1,341 @@ +(* Guestfs Browser. + * Copyright (C) 2010 Red Hat Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + *) + +open Printf + +open Utils + +module G = Guestfs + +let (//) = Filename.concat + +(* Display state. *) +type display_state = { + window : GWindow.window; + throbber_busy : unit -> unit; + throbber_idle : unit -> unit; + set_statusbar : string -> unit; + clear_statusbar : unit -> unit; + set_vmlist : string list -> unit; + clear_vmlist : unit -> unit; + clear_notebook : unit -> unit; + filesystem : GPack.box; + notebook : GPack.notebook; +} + +let rec open_main_window () = + let title = "Guest Filesystem Browser" in + let window = GWindow.window ~width:800 ~height:600 ~title () in + let vbox = GPack.vbox ~packing:window#add () in + + (* Do the menus. *) + let menubar = GMenu.menu_bar ~packing:vbox#pack () in + let factory = new GMenu.factory menubar in + let accel_group = factory#accel_group in + let connect_menu = factory#add_submenu "_Connect" in + + let factory = new GMenu.factory connect_menu ~accel_group in + let connect_item = factory#add_item "_Connect to libvirt ..." in + let open_item = factory#add_item "_Open disk image ..." ~key:GdkKeysyms._O in + ignore (factory#add_separator ()); + let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in + + (* Quit. *) + let quit _ = GMain.quit (); false in + ignore (window#connect#destroy ~callback:GMain.quit); + ignore (window#event#connect#delete ~callback:quit); + ignore (quit_item#connect#activate + ~callback:(fun () -> ignore (quit ()); ())); + + (* Top status area. *) + let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in + hbox#pack (mklabel "Guest: "); + + (* List of VMs. *) + let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in + let set_vmlist names = + let combo, (model, column) = vmcombo in + model#clear (); + List.iter ( + fun name -> + let row = model#append () in + model#set ~row ~column name + ) names + in + let clear_vmlist () = set_vmlist [] in + + (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *) + let static = Throbber.static () in + (*let animation = Throbber.animation () in*) + let throbber = + GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in + let throbber_busy () = + (*throbber#set_pixbuf animation*) + (* Workaround because no binding for GdkPixbufAnimation: *) + let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in + throbber#set_file file + and throbber_idle () = + throbber#set_pixbuf static + in + + (* Tabbed pane ("notebook") filling the main window. *) + let nb = GPack.notebook ~scrollable:true + ~packing:(vbox#pack ~expand:true ~fill:true) () in + let filesystem = GPack.vbox () in + filesystem#add (intro_label () :> GObj.widget); + ignore (nb#append_page + ~tab_label:(mklabel "Filesystem") (filesystem :> GObj.widget)); + let clear_notebook () = + nb#goto_page 0; + (* Remove all tabs except the first ("Filesystem") tab ... *) + List.iter nb#remove (List.tl nb#all_children); + (* ... and clear out the filesystem tab. *) + List.iter filesystem#remove filesystem#all_children + in + + (* Status bar at the bottom of the screen. *) + let set_statusbar = + let statusbar = GMisc.statusbar ~packing:vbox#pack () in + let context = statusbar#new_context ~name:"Standard" in + ignore (context#push title); + fun msg -> + context#pop (); + ignore (context#push msg) + in + let clear_statusbar () = set_statusbar "" in + + window#show (); + window#add_accel_group accel_group; + + (* display_state which is threaded through all the other callbacks, + * allowing callbacks to update the window. + *) + let ds = { + window = window; + throbber_busy = throbber_busy; throbber_idle = throbber_idle; + set_statusbar = set_statusbar; clear_statusbar = clear_statusbar; + set_vmlist = set_vmlist; clear_vmlist = clear_vmlist; + clear_notebook = clear_notebook; + filesystem = filesystem; notebook = nb; + } in + + (* Set up some callbacks which require access to the display_state. *) + ignore ( + let combo, (model, column) = vmcombo in + combo#connect#changed + ~callback:( + fun () -> + match combo#active_iter with + | None -> () + | Some row -> + let name = model#get ~row ~column in + ds.set_statusbar (sprintf "Opening %s ..." name); + ds.clear_notebook (); + Slave.open_domain name (opened_domain ds)) + ); + + ignore (connect_item#connect#activate ~callback:(connect_dialog ds)); + ignore (open_item#connect#activate ~callback:(open_dialog ds)); + + (* Return the display state. *) + ds + +(* Convenience function to make a label containing some text. It is + * returned as a generic widget. + *) +and mklabel text = + (GMisc.label ~text () :> GObj.widget) + +(* This is called in the main thread whenever a command fails in the + * slave thread. The command queue has been cleared before this is + * called, so our job here is to reset the main window, and if + * necessary to turn the exception into an error message. + *) +and failure ds exn = + let title = "Error" in + let msg = Printexc.to_string exn in + debug "thread id %d: failure hook: %s" (Thread.id (Thread.self ())) msg; + let icon = GMisc.image () in + icon#set_stock `DIALOG_ERROR; + icon#set_icon_size `DIALOG; + GToolbox.message_box ~title ~icon msg + +(* This is called in the main thread when we've connected to libvirt. *) +and connected ds uri () = + debug "thread id %d: connected callback" (Thread.id (Thread.self ())); + let msg = + match uri with + | None -> "Connected to libvirt" + | Some uri -> sprintf "Connected to %s" uri in + ds.set_statusbar msg; + Slave.get_domains (got_domains ds) + +(* This is called in the main thread when we've got the list of domains. *) +and got_domains ds doms = + let doms = List.map (fun { Slave.dom_name = name } -> name) doms in + debug "thread id %d: got_domains callback: (%s)" + (Thread.id (Thread.self ())) (String.concat " " doms); + ds.set_vmlist doms + +(* This callback indicates that the domain was opened successfully. *) +and opened_domain ds rw = + debug "thread id %d: opened_domain callback" (Thread.id (Thread.self ())); + opened ds rw + +(* This callback indicates that local disk image(s) were opened successfully.*) +and opened_images ds rw = + debug "thread id %d: opened_images callback" (Thread.id (Thread.self ())); + opened ds rw + +and opened ds rw = + ds.clear_statusbar (); + ds.clear_notebook (); + + (* Get the list of mountable filesystems. *) + Slave.get_volumes (got_volume ds rw) + +(* This callback is called once for each mountable filesystem that is + * found in a guest. + *) +and got_volume ds rw vol = + let dev = vol.Slave.vol_device in + debug "thread id %d: got_volume callback: %s" + (Thread.id (Thread.self ())) dev; + + (* What's on the tab. *) + let tab = + match vol.Slave.vol_label with + | "" -> sprintf "%s" dev + | label -> sprintf "%s (%s)" dev label in + + (* What's on the notebook page. *) + let page = + let vbox = GPack.vbox () in + + (* VFS stats table. *) + + (* For calculations, see libguestfs/tools/virt-df. *) + let st = vol.Slave.vol_statvfs in + let factor = st.G.bsize /^ 1024L in + + (* Right-aligned label with width, for stats table. *) + let mklabelh text = + let markup = "" ^ 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_dialog ds () = + debug "connect menu"; + (*ds.clear_notebook ();*) + failwith "XXX CONNECT DLG NOT IMPL" + +(* Open the disk images dialog. *) +and open_dialog ds () = + debug "open menu"; + (*ds.clear_notebook ();*) + failwith "XXX OPEN DLG NOT IMPL" + +(* The introductory text which appears in the tabbed notebook to + * tell the user how to start. XXX We should add images. + *) +and intro_label () = + let text = + sprintf "Open a disk image (Connect %s Open disk image), connect to libvirt (Connect %s Connect to libvirt), or choose a guest from the \"Guest\" menu above." + utf8_rarrow utf8_rarrow in + let label = GMisc.label ~text () in + label#set_line_wrap true; + label + +let run_cli_request ds = function + | Cmdline.Empty_window -> () + | Cmdline.Connect_to_libvirt uri -> + Slave.connect uri (connected ds uri) + | Cmdline.Open_disk_image images -> + Slave.open_images images (opened_images ds) diff --git a/window.mli b/window.mli new file mode 100644 index 0000000..916bb15 --- /dev/null +++ b/window.mli @@ -0,0 +1,49 @@ +(* Guestfs Browser. + * Copyright (C) 2010 Red Hat Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + *) + +(** The Window module handles all aspects of the main window, menus, + dialogs and so on. *) + +type display_state = { + window : GWindow.window; + throbber_busy : unit -> unit; + throbber_idle : unit -> unit; + set_statusbar : string -> unit; + clear_statusbar : unit -> unit; + set_vmlist : string list -> unit; + clear_vmlist : unit -> unit; + clear_notebook : unit -> unit; + filesystem : GPack.box; + notebook : GPack.notebook; +} + (** This structure describes various variables and functions + for the main window. It is returned from {!open_main_window} + and passed around to various other functions. *) + +val open_main_window : unit -> display_state + (** Open the main Gtk window, set up the menus, callbacks and so on. *) + +val failure : display_state -> exn -> unit + (** This is the global error handling function. It is invoked in + the main thread for failures in the slave thread (see + {!Slave.set_failure_hook}). *) + +val run_cli_request : display_state -> Cmdline.cli_request -> unit + (** This function performs the {!Cmdline.cli_request} operation. + The actual operation happens asynchronously after this function + has returned. *)