From b07102fda0034da5840a9f33bd6d404a195b8cc9 Mon Sep 17 00:00:00 2001 From: Richard Jones Date: Wed, 16 Jun 2010 11:59:09 +0100 Subject: [PATCH] Version 0.0.1 --- .gitignore | 20 +++ HACKING | 3 + Makefile.am | 50 +++++-- README | 25 ++++ TODO | 3 + cmdline.ml | 82 +++++++++++ cmdline.mli | 30 ++++ config.ml.in | 20 +++ configure.ac | 25 +++- filetree.ml | 442 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ filetree.mli | 33 +++++ main.ml | 84 ++++-------- slave.ml | 252 +++++++++++++++++++++++++++++++--- slave.mli | 64 ++++++++- throbber.ml | 48 +++++++ utils.ml | 38 ++++- utils.mli | 27 +++- window.ml | 341 +++++++++++++++++++++++++++++++++++++++++++++ window.mli | 49 +++++++ 19 files changed, 1542 insertions(+), 94 deletions(-) create mode 100644 README create mode 100644 TODO create mode 100644 cmdline.ml create mode 100644 cmdline.mli create mode 100644 config.ml.in create mode 100644 filetree.ml create mode 100644 filetree.mli create mode 100644 throbber.ml create mode 100644 window.ml create mode 100644 window.mli 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. *) -- 1.8.3.1