From 73f1dc10b4279528818fe0fda33daf4c34488d21 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 14 Dec 2010 10:29:33 +0000 Subject: [PATCH] Daily check-in. --- .depend | 6 +- Makefile.am | 9 ++ TODO | 24 +++++- cmdline.ml | 95 ++++++++++++++++++++ cmdline.mli | 34 ++++++++ filetree.ml | 253 ++++++++++++++++++++++++++++++++++++------------------ filetree.mli | 17 +++- filetree_ops.ml | 145 +++++++++++++++++++++++++++++++ filetree_ops.mli | 35 ++++++++ filetree_type.ml | 102 ++++++++++++++++++++++ filetree_type.mli | 66 ++++++++++++++ main.ml | 5 +- slave.ml | 70 ++++++++++++++- slave.mli | 20 +++++ utils.ml | 8 ++ utils.mli | 12 +++ window.ml | 32 +++++++ window.mli | 10 +-- 18 files changed, 838 insertions(+), 105 deletions(-) create mode 100644 cmdline.ml create mode 100644 cmdline.mli create mode 100644 filetree_ops.ml create mode 100644 filetree_ops.mli create mode 100644 filetree_type.ml create mode 100644 filetree_type.mli diff --git a/.depend b/.depend index bc52fb7..742d484 100644 --- a/.depend +++ b/.depend @@ -10,9 +10,9 @@ deviceSet.cmx: deviceSet.cmi filetree.cmi: slave.cmi filetree.cmo: utils.cmi slave.cmi filetree_type.cmi filetree_ops.cmi deviceSet.cmi filetree.cmi filetree.cmx: utils.cmx slave.cmx filetree_type.cmx filetree_ops.cmx deviceSet.cmx filetree.cmi -filetree_ops.cmi: filetree_type.cmi -filetree_ops.cmo: utils.cmi filetree_type.cmi filetree_ops.cmi -filetree_ops.cmx: utils.cmx filetree_type.cmx filetree_ops.cmi +filetree_ops.cmi: slave.cmi filetree_type.cmi +filetree_ops.cmo: utils.cmi slave.cmi filetree_type.cmi filetree_ops.cmi +filetree_ops.cmx: utils.cmx slave.cmx filetree_type.cmx filetree_ops.cmi filetree_type.cmi: slave.cmi filetree_type.cmo: utils.cmi slave.cmi filetree_type.cmi filetree_type.cmx: utils.cmx slave.cmx filetree_type.cmi diff --git a/Makefile.am b/Makefile.am index cfab18c..2967d7e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -27,12 +27,18 @@ CLEANFILES = *.cmi *.cmo *.cmx *.o guestfs-browser # These are listed here in alphabetical order. SOURCES = \ + cmdline.mli \ + cmdline.ml \ config.mli \ config.ml \ deviceSet.mli \ deviceSet.ml \ filetree.mli \ filetree.ml \ + filetree_ops.mli \ + filetree_ops.ml \ + filetree_type.mli \ + filetree_type.ml \ main.ml \ slave.mli \ slave.ml \ @@ -47,8 +53,11 @@ OBJECTS = \ config.cmx \ throbber.cmx \ utils.cmx \ + cmdline.cmx \ deviceSet.cmx \ slave.cmx \ + filetree_type.cmx \ + filetree_ops.cmx \ filetree.cmx \ window.cmx \ main.cmx diff --git a/TODO b/TODO index 08f0aba..1e4a09c 100644 --- a/TODO +++ b/TODO @@ -1,3 +1,23 @@ -The context menu does nothing at the moment. +Context menu: -The menu items do nothing at the moment. +. Open file (view / open dir) +. Download +. Download as tarball +. File type & info (stat, file, arch, xattrs) +. Filesystem used & free +. Disk space usage +. Block device info (size, UUID, label, ...) +. Checksum +x Device checksum (slow?) +. Directory listing (find0) +. Inspection data +? LV information +? Ext2 superblock info (tune2fs) + +Display Windows Registry as a separate tree. + +The slave thread should not have to remount filesystems. +If the mount points are the same as the previous command, it +should cache them. + +About dialog diff --git a/cmdline.ml b/cmdline.ml new file mode 100644 index 0000000..e0f244b --- /dev/null +++ b/cmdline.ml @@ -0,0 +1,95 @@ +(* 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 = + | Empty_window + | Open_guest of string + | Open_images of (string * string option) list + +let format = ref None +let images = ref [] +let guests = ref [] + +let set_connect = function + | "" -> set_connect_uri None + | uri -> set_connect_uri (Some uri) +let set_format = function + | "" -> format := None + | f -> format := Some f +let add_image image = + images := (image, !format) :: !images +let add_guest guest = + guests := guest :: !guests + +(* Parse command line arguments. *) +let argspec = Arg.align [ + "-a", Arg.String add_image, "image Open disk image"; + "--add", Arg.String add_image, "image Open disk image"; + "-c", Arg.String set_connect, "uri Connect to libvirt URI"; + "--connect", Arg.String set_connect, "uri Connect to libvirt URI"; + "-d", Arg.String add_guest, "guest Open libvirt guest"; + "--domain", Arg.String add_guest, "guest Open libvirt guest"; + "--format", Arg.String set_format, "format Set format"; + "-v", Arg.Unit set_verbose_flag, " Enable debugging messages"; + "--verbose", Arg.Unit set_verbose_flag, " Enable debugging messages"; + "-V", Arg.Unit set_verbose_flag, " Display version and exit"; + "--version", Arg.Unit set_verbose_flag, " Display version and exit"; + "-x", Arg.Unit set_trace_flag, " Enable tracing of libguestfs calls"; +] + +let prog = Filename.basename Sys.executable_name + +let anon_fun _ = + raise (Arg.Bad "unknown argument") + +let usage_msg = + sprintf "\ +%s: graphical guest filesystem browser + +Usage: + %s + Open the program with an empty window. + + %s -a disk.img [-a disk.img [...]] + Start with a guest from a disk image file. + + %s -d guest + Start with the named libvirt guest. + +Options:" + prog prog prog prog + +let command_line () = + Arg.parse argspec anon_fun usage_msg; + + (* Verify number of -a and -d options given on the command line. *) + let images = List.rev !images in + let guests = List.rev !guests in + + match images, guests with + | [], [] -> Empty_window + | _, [] -> Open_images images + | [], [guest] -> Open_guest guest + | [], _ -> + failwith "cannot use -d option more than once" + | _, _ -> + failwith "cannot mix -a and -d options" diff --git a/cmdline.mli b/cmdline.mli new file mode 100644 index 0000000..14727db --- /dev/null +++ b/cmdline.mli @@ -0,0 +1,34 @@ +(* 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 = + | Empty_window + | Open_guest of string + | Open_images of (string * string option) list + (** The initial action requested by the user on the command line. + + [Empty_window] means nothing was requested on the command line. + + [Open_guest] means to open a guest (-d option). + + [Open_images] means to open a list of disk images (-a option). *) + +val command_line : unit -> cli_request + (** Read the command line and return {!cli_request}. *) diff --git a/filetree.ml b/filetree.ml index af871a7..ecdba77 100644 --- a/filetree.ml +++ b/filetree.ml @@ -17,52 +17,23 @@ *) open ExtString +open ExtList open Printf open Utils open DeviceSet +open Filetree_type +open Filetree_ops + module G = Guestfs -type t = { - view : GTree.view; - model : GTree.tree_store; - hash : (int, hdata) Hashtbl.t; (* hash from index_col -> hdata *) - index_col : int GTree.column; - mode_col : string GTree.column; - name_col : string GTree.column; - size_col : int64 GTree.column; - date_col : string GTree.column; - link_col : string GTree.column; -} - -and hdata = state_t * content_t - -(* The type of the hidden column used to implement on-demand loading. - * All rows are classified as either nodes or leafs (eg. a "node" might - * be a directory, or a top-level operating system, or anything else - * which the user could open and look inside). - *) -and state_t = - | IsLeaf (* there are no children *) - | NodeNotStarted (* user has not tried to open this *) - | NodeLoading (* user tried to open it, still loading *) - | IsNode (* we've loaded the children of this directory *) - -(* The actual content of a row. *) -and content_t = - | Loading (* special "loading ..." node *) - | ErrorMessage of string (* error message node *) - | Top of Slave.source (* top level OS or volume node *) - | Directory of Slave.direntry (* a directory *) - | File of Slave.direntry (* a file inc. special files *) - -let loading_msg = "Loading ..." - -let create ~packing () = +type t = Filetree_type.t + +let rec create ?status ~packing () = let view = GTree.view ~packing () in (*view#set_rules_hint true;*) - view#selection#set_mode `MULTIPLE; + (*view#selection#set_mode `MULTIPLE; -- add this later *) (* Hash of index numbers -> hdata. We do this because it's more * efficient for the GC compared to storing OCaml objects directly in @@ -110,14 +81,162 @@ let create ~packing () = let link_view = GTree.view_column ~title:"Link" ~renderer () in ignore (view#append_column link_view); - { view = view; model = model; hash = hash; + let t = { + view = view; model = model; hash = hash; index_col = index_col; mode_col = mode_col; name_col = name_col; size_col = size_col; - date_col = date_col; link_col = link_col } + date_col = date_col; link_col = link_col; + status = status + } in -let clear { model = model; hash = hash } = - model#clear (); - Hashtbl.clear hash + (* Open a context menu when a button is pressed. *) + ignore (view#event#connect#button_press ~callback:(button_press t)); + + t + +(* 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 ({ model = model; view = view } as t) 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 ( +(* + (* 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 +*) + (* Select the row under the mouse. *) + let paths = + let sel = view#selection in + match view#get_path_at_pos ~x ~y with + | None -> [] + | Some (path, _, _, _) -> + sel#unselect_all (); + sel#select_path path; + [path] in + + (* Get the hdata for all the paths. Filter out rows that it doesn't + * make sense to select. + *) + let paths = + List.filter_map ( + fun path -> + let row = model#get_iter path in + let hdata = get_hdata t row in + match hdata with + | _, (Loading | ErrorMessage _) -> None + | _, (Top _ | Directory _ | File _) -> Some (path, hdata) + ) paths in + + (* Based on number of selected rows and what is selected, construct + * the context menu. + *) + if paths <> [] then ( + let menu = make_context_menu t paths in + menu#popup ~button ~time + ); + + (* Return true so no other handler will run. *) + true + ) + (* We didn't handle this, defer to other handlers. *) + else false + +and make_context_menu t paths = + let menu = GMenu.menu () in + let factory = new GMenu.factory menu in + + let item = factory#add_item "Open" in + item#misc#set_sensitive false; + + let rec add_file_items path = + let item = factory#add_item "File information" in + item#misc#set_sensitive false; + let item = factory#add_item "Checksum" in + item#misc#set_sensitive false; + ignore (factory#add_separator ()); + let item = factory#add_item "Download ..." in + ignore (item#connect#activate ~callback:(download_file t path)); + + and add_directory_items path = + let item = factory#add_item "Directory information" in + item#misc#set_sensitive false; + let item = factory#add_item "Space used by directory" in + item#misc#set_sensitive false; + ignore (factory#add_separator ()); + let item = factory#add_item "Download ..." in + item#misc#set_sensitive false; + let item = factory#add_item "Download as .tar ..." in + ignore (item#connect#activate + ~callback:(download_dir_tarball t Slave.Tar path)); + let item = factory#add_item "Download as .tar.gz ..." in + ignore (item#connect#activate + ~callback:(download_dir_tarball t Slave.TGZ path)); + let item = factory#add_item "Download as .tar.xz ..." in + ignore (item#connect#activate + ~callback:(download_dir_tarball t Slave.TXZ path)); + let item = factory#add_item "Download list of filenames ..." in + ignore (item#connect#activate ~callback:(download_dir_find0 t path)); + + and add_os_items path = + let item = factory#add_item "Operating system information" in + item#misc#set_sensitive false; + let item = factory#add_item "Block device information" in + item#misc#set_sensitive false; + let item = factory#add_item "Filesystem used & free" in + item#misc#set_sensitive false; + ignore (factory#add_separator ()); + add_directory_items path + + and add_volume_items path = + let item = factory#add_item "Filesystem used & free" in + item#misc#set_sensitive false; + let item = factory#add_item "Block device information" in + item#misc#set_sensitive false; + ignore (factory#add_separator ()); + add_directory_items path + in + + (match paths with + (* single selection *) + | [path, (_, Top (Slave.OS os))] -> (* top level operating system *) + add_os_items path + + | [path, (_, Top (Slave.Volume dev))] -> (* top level volume *) + add_volume_items path + + | [path, (_, Directory direntry)] -> (* directory *) + add_directory_items path + + | [path, (_, File direntry)] -> (* file *) + add_file_items path + + | [_, (_, Loading)] + | [_, (_, ErrorMessage _)] -> () + + | _ -> + (* At the moment multiple selection is disabled. When/if we + * enable it we should do something intelligent here. XXX + *) + () + ); + + menu (* XXX No binding for g_markup_escape in lablgtk2. *) let markup_escape name = @@ -187,17 +306,9 @@ and markup_of_date time = (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec -(* Store hdata into a row. *) -let store_hdata {model = model; hash = hash; index_col = index_col} row hdata = - let index = unique () in - Hashtbl.add hash index hdata; - model#set ~row ~column:index_col index - -(* Retrieve previously stored hdata from a row. *) -let get_hdata { model = model; hash = hash; index_col = index_col } row = - let index = model#get ~row ~column:index_col in - try Hashtbl.find hash index - with Not_found -> assert false +let clear { model = model; hash = hash } = + model#clear (); + Hashtbl.clear hash let rec add ({ model = model; hash = hash } as t) name data = clear t; @@ -257,7 +368,7 @@ and make_node ({ model = model; hash = hash } as t) row content = let placeholder = model#append ~parent:row () in let hdata = IsLeaf, Loading in store_hdata t placeholder hdata; - model#set ~row:placeholder ~column:t.name_col loading_msg; + model#set ~row:placeholder ~column:t.name_col "Loading ..."; ignore (t.view#connect#row_expanded ~callback:(expand_row t)) and make_leaf ({ model = model; hash = hash } as t) row content = @@ -303,37 +414,6 @@ and expand_row ({ model = model; hash = hash } as t) row _ = (* Node should not exist in the tree. *) | NodeNotStarted, (Loading | ErrorMessage _) -> assert false -(* Search up to the top of the tree so we know if this directory - * comes from an OS or a volume, and the full path to here. - * - * The path up the tree will always look something like: - * Top - * \_ Directory - * \_ Directory - * \_ Loading <--- you are here - *) -and get_pathname ({ model = model } as t) row = - let hdata = get_hdata t row in - let parent = model#iter_parent row in - - match hdata, parent with - | (IsLeaf, Loading), Some parent -> - get_pathname t parent - | (IsLeaf, Loading), None -> - assert false - | (_, Directory { Slave.dent_name = name }), Some parent - | (_, File { Slave.dent_name = name }), Some parent -> - let src, parent_name = get_pathname t parent in - let path = - if parent_name = "/" then "/" ^ name - else parent_name ^ "/" ^ name in - src, path - | (_, Top src), _ -> src, "/" - | (_, Directory _), None -> assert false - | (_, File _), None -> assert false - | (_, Loading), _ -> assert false - | (_, ErrorMessage _), _ -> assert false - (* This is the callback when the slave has read the directory for us. *) and when_read_directory ({ model = model } as t) path entries = debug "when_read_directory"; @@ -393,3 +473,6 @@ and when_read_directory_fail ({ model = model } as t) path exn = | exn -> (* unexpected exception: re-raise it *) raise exn + +let set_status_fn t status = + t.status <- Some status diff --git a/filetree.mli b/filetree.mli index 46fd39a..cd047cc 100644 --- a/filetree.mli +++ b/filetree.mli @@ -27,9 +27,19 @@ http://mail.gnome.org/archives/gtk-app-devel-list/2003-May/msg00241.html *) type t + (** A filetree widget. Actually an opaque object which contains the + widget and other data. Use the accessors below. *) -val create : packing:(GObj.widget -> unit) -> unit -> t - (** Create a new filetree widget (empty). *) +val create : ?status:(string -> unit) -> packing:(GObj.widget -> unit) -> unit -> t + (** Create a new filetree widget (empty). + + In the optional [?status] parameter you can pass in some + function that updates a status bar. This function will be + called by the filetree whenever the user should be told about + some ordinary event having happened (for example, that a file is + being downloaded or has finished downloading). + + [~packing] is the required packing for the widget. *) val clear : t -> unit (** Clear out all rows in existing widget. *) @@ -39,3 +49,6 @@ val add : t -> string -> Slave.inspection_data -> unit system and/or filesystems described by the [data] struct. The [name] parameter should be some host-side (verifiable) name; usually we pass the name of the guest from libvirt here. *) + +val set_status_fn : t -> (string -> unit) -> unit + (** Set or update the [status] function. *) diff --git a/filetree_ops.ml b/filetree_ops.ml new file mode 100644 index 0000000..c273f30 --- /dev/null +++ b/filetree_ops.ml @@ -0,0 +1,145 @@ +(* 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 + +open Filetree_type + +(* Get the basename of a file, using path conventions which are valid + * for libguestfs. So [Filename.basename] won't necessarily work + * because it will use host path conventions. + *) +let basename pathname = + let len = String.length pathname in + try + let i = String.rindex pathname '/' in + let r = String.sub pathname (i+1) (len-i-1) in + if r = "" then "root" else r + with + Not_found -> pathname + +(* Download a single file. *) +let rec download_file ({ model = model } as t) path () = + let row = model#get_iter path in + let src, pathname = get_pathname t row in + debug "download_file %s: showing dialog" pathname; + + (* Put up the dialog. *) + let title = "Download file" in + let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in + dlg#add_button_stock `CANCEL `CANCEL; + dlg#add_select_button_stock `SAVE `SAVE; + dlg#set_current_name (basename pathname); + + match dlg#run () with + | `DELETE_EVENT | `CANCEL -> + dlg#destroy () + | `SAVE -> + match dlg#filename with + | None -> () + | Some localfile -> + dlg#destroy (); + + (* Download the file. *) + update_status t + (sprintf "Downloading %s to %s ..." pathname localfile); + Slave.download_file src pathname localfile + (when_downloaded_file t pathname localfile) + +and when_downloaded_file t _ localfile () = + update_status t (sprintf "Finished downloading %s" localfile) + +(* Download a directory as a tarball. *) +let rec download_dir_tarball ({ model = model } as t) format path () = + let row = model#get_iter path in + let src, pathname = get_pathname t row in + debug "download_dir_tarball %s: showing dialog" pathname; + + (* Put up the dialog. *) + let title = "Download directory to tar file" in + let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in + dlg#add_button_stock `CANCEL `CANCEL; + dlg#add_select_button_stock `SAVE `SAVE; + + let extension = match format with + | Slave.Tar -> ".tar" + | Slave.TGZ -> ".tar.gz" + | Slave.TXZ -> ".tar.xz" + in + dlg#set_current_name (basename pathname ^ extension); + + match dlg#run () with + | `DELETE_EVENT | `CANCEL -> + dlg#destroy () + | `SAVE -> + match dlg#filename with + | None -> () + | Some localfile -> + dlg#destroy (); + + (* Download the directory. *) + update_status t + (sprintf "Downloading %s to %s ..." pathname localfile); + Slave.download_dir_tarball src pathname format localfile + (when_downloaded_dir_tarball t pathname localfile) + +and when_downloaded_dir_tarball t _ localfile () = + update_status t (sprintf "Finished downloading %s" localfile) + +let rec download_dir_find0 ({ model = model } as t) path () = + let row = model#get_iter path in + let src, pathname = get_pathname t row in + debug "download_dir_find0 %s: showing dialog" pathname; + + (* Put up the dialog. *) + let title = "Download list of filenames" in + let dlg = GWindow.file_chooser_dialog ~action:`SAVE ~title ~modal:true () in + dlg#add_button_stock `CANCEL `CANCEL; + dlg#add_select_button_stock `SAVE `SAVE; + dlg#set_current_name (basename pathname ^ ".filenames.txt"); + + (* Notify that the list of strings is \0 separated. *) + let hbox = + let hbox = GPack.hbox () in + ignore (GMisc.image ~stock:`INFO ~packing:hbox#pack ()); + let label = GMisc.label + ~text:"The list of filenames is saved to a file with zero byte separators, to allow the full range of characters to be used in the names themselves." + ~packing:hbox#pack () in + label#set_line_wrap true; + hbox in + dlg#set_extra_widget (hbox :> GObj.widget); + + match dlg#run () with + | `DELETE_EVENT | `CANCEL -> + dlg#destroy () + | `SAVE -> + match dlg#filename with + | None -> () + | Some localfile -> + dlg#destroy (); + + (* Download the directory. *) + update_status t + (sprintf "Downloading filenames in %s to %s ..." pathname localfile); + Slave.download_dir_find0 src pathname localfile + (when_downloaded_dir_find0 t pathname localfile) + +and when_downloaded_dir_find0 t _ localfile () = + update_status t (sprintf "Finished downloading %s" localfile) diff --git a/filetree_ops.mli b/filetree_ops.mli new file mode 100644 index 0000000..dacbd88 --- /dev/null +++ b/filetree_ops.mli @@ -0,0 +1,35 @@ +(* 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. + *) + +(** Operations on a file tree. + + This module contains operations performed by menu items or + from the context menu. + + The types and functions in this file should be considered + private to the file tree implementation. + + See {!Filetree} for the full description and public interface. *) + +(**/**) + +val download_file : Filetree_type.t -> Gtk.tree_path -> unit -> unit + +val download_dir_tarball : Filetree_type.t -> Slave.download_dir_tarball_format -> Gtk.tree_path -> unit -> unit + +val download_dir_find0 : Filetree_type.t -> Gtk.tree_path -> unit -> unit diff --git a/filetree_type.ml b/filetree_type.ml new file mode 100644 index 0000000..9c80e97 --- /dev/null +++ b/filetree_type.ml @@ -0,0 +1,102 @@ +(* 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 Utils + +type t = { + view : GTree.view; + model : GTree.tree_store; + hash : (int, hdata) Hashtbl.t; (* hash from index_col -> hdata *) + index_col : int GTree.column; + mode_col : string GTree.column; + name_col : string GTree.column; + size_col : int64 GTree.column; + date_col : string GTree.column; + link_col : string GTree.column; + mutable status : (string -> unit) option; +} + +and hdata = state_t * content_t + +(* The type of the hidden column used to implement on-demand loading. + * All rows are classified as either nodes or leafs (eg. a "node" might + * be a directory, or a top-level operating system, or anything else + * which the user could open and look inside). + *) +and state_t = + | IsLeaf (* there are no children *) + | NodeNotStarted (* user has not tried to open this *) + | NodeLoading (* user tried to open it, still loading *) + | IsNode (* we've loaded the children of this directory *) + +(* The actual content of a row. *) +and content_t = + | Loading (* special "loading ..." node *) + | ErrorMessage of string (* error message node *) + | Top of Slave.source (* top level OS or volume node *) + | Directory of Slave.direntry (* a directory *) + | File of Slave.direntry (* a file inc. special files *) + +(* Store hdata into a row. *) +let store_hdata {model = model; hash = hash; index_col = index_col} row hdata = + let index = unique () in + Hashtbl.add hash index hdata; + model#set ~row ~column:index_col index + +(* Retrieve previously stored hdata from a row. *) +let get_hdata { model = model; hash = hash; index_col = index_col } row = + let index = model#get ~row ~column:index_col in + try Hashtbl.find hash index + with Not_found -> assert false + +(* Search up to the top of the tree so we know if this directory + * comes from an OS or a volume, and the full path to here. + * + * The path up the tree will always look something like: + * Top + * \_ Directory + * \_ Directory + * \_ Loading <--- you are here + *) +let rec get_pathname ({ model = model } as t) row = + let hdata = get_hdata t row in + let parent = model#iter_parent row in + + match hdata, parent with + | (IsLeaf, Loading), Some parent -> + get_pathname t parent + | (IsLeaf, Loading), None -> + assert false + | (_, Directory { Slave.dent_name = name }), Some parent + | (_, File { Slave.dent_name = name }), Some parent -> + let src, parent_name = get_pathname t parent in + let path = + if parent_name = "/" then "/" ^ name + else parent_name ^ "/" ^ name in + src, path + | (_, Top src), _ -> src, "/" + | (_, Directory _), None -> assert false + | (_, File _), None -> assert false + | (_, Loading), _ -> assert false + | (_, ErrorMessage _), _ -> assert false + +(* Update the status bar. *) +let update_status { status = f } msg = + match f with + | None -> () (* user didn't give us a [status] function to call *) + | Some f -> f msg diff --git a/filetree_type.mli b/filetree_type.mli new file mode 100644 index 0000000..af36dee --- /dev/null +++ b/filetree_type.mli @@ -0,0 +1,66 @@ +(* 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. + *) + +(** This is the base class for the file tree. + + The types and functions in this file should be considered + private to the file tree implementation. + + See {!Filetree} for the full description and public interface. *) + +(**/**) + +type t = { + view : GTree.view; + model : GTree.tree_store; + hash : (int, hdata) Hashtbl.t; + index_col : int GTree.column; + mode_col : string GTree.column; + name_col : string GTree.column; + size_col : int64 GTree.column; + date_col : string GTree.column; + link_col : string GTree.column; + mutable status : (string -> unit) option; +} + +and hdata = state_t * content_t + +and state_t = + | IsLeaf + | NodeNotStarted + | NodeLoading + | IsNode + +and content_t = + | Loading + | ErrorMessage of string + | Top of Slave.source + | Directory of Slave.direntry + | File of Slave.direntry + +val store_hdata : t -> Gtk.tree_iter -> hdata -> unit +val get_hdata : t -> Gtk.tree_iter -> hdata + (* Store/retrieve hdata structure in a model row. *) + +val get_pathname : t -> Gtk.tree_iter -> Slave.source * string + (* Get the full path to a row by chasing up through the tree to the + top. This also returns the source (eg. operating system or single + volume). *) + +val update_status : t -> string -> unit + (* Update the status bar. *) diff --git a/main.ml b/main.ml index 25215ac..fafe7d6 100644 --- a/main.ml +++ b/main.ml @@ -22,8 +22,7 @@ open Utils (* Main. *) let () = - (* XXX command line *) - Utils.set_verbose_flag (); + let cli_request = Cmdline.command_line () in (* If we're in verbose mode, print some debug information which * could be useful in bug reports. @@ -41,7 +40,7 @@ let () = Slave.set_progress_hook (Window.progress ws); (* What did the user request on the command line? *) - (*Window.run_cli_request ws cli_request;*) + Window.run_cli_request ws cli_request; (* Run the main display thread. When this returns, the application * has been closed. diff --git a/slave.ml b/slave.ml index 1c56538..17f00b7 100644 --- a/slave.ml +++ b/slave.ml @@ -32,6 +32,9 @@ type 'a callback = 'a -> unit type command = | Exit_thread | Connect of string option * domain list callback + | Download_dir_find0 of source * string * string * unit callback + | Download_dir_tarball of source * string * download_dir_tarball_format * string * unit callback + | Download_file of source * string * string * unit callback | Open_domain of string * inspection_data callback | Open_images of (string * string option) list * inspection_data callback | Read_directory of source * string * direntry list callback @@ -71,17 +74,27 @@ and direntry = { dent_link : string; } +and download_dir_tarball_format = Tar | TGZ | TXZ + let rec string_of_command = function | Exit_thread -> "Exit_thread" | Connect (Some name, _) -> sprintf "Connect %s" name | Connect (None, _) -> "Connect NULL" + | Download_dir_find0 (src, remotedir, localfile, _) -> + sprintf "Download_dir_find0 (%s, %s, %s)" + (string_of_source src) remotedir localfile + | Download_dir_tarball (src, remotedir, format, localfile, _) -> + sprintf "Download_dir_tarball (%s, %s, %s, %s)" + (string_of_source src) remotedir + (string_of_download_dir_tarball_format format) localfile + | Download_file (src, remotefile, localfile, _) -> + sprintf "Download_file (%s, %s, %s)" + (string_of_source src) remotefile localfile | Open_domain (name, _) -> sprintf "Open_domain %s" name | Open_images (images, _) -> sprintf "Open_images %s" (string_of_images images) - | Read_directory (OS { insp_root = root }, dir, _) -> - sprintf "Read_directory (OS %s, %s)" root dir - | Read_directory (Volume dev, dir, _) -> - sprintf "Read_directory (Volume %s, %s)" dev dir + | Read_directory (src, dir, _) -> + sprintf "Read_directory (%s, %s)" (string_of_source src) dir and string_of_images images = "[" ^ @@ -91,6 +104,17 @@ and string_of_images images = | fn, Some format -> sprintf "%s (%s)" fn format) images) ^ "]" +and string_of_source = function + | OS { insp_root = root } -> + sprintf "OS %s" root + | Volume dev -> + sprintf "Volume %s" dev + +and string_of_download_dir_tarball_format = function + | Tar -> "Tar" + | TGZ -> "TGZ" + | TXZ -> "TXZ" + let no_callback _ = () let failure_hook = ref (fun _ -> ()) @@ -139,6 +163,13 @@ let discard_command_queue () = ) let connect ?fail uri cb = send_to_slave ?fail (Connect (uri, cb)) +let download_dir_find0 ?fail src remotedir localfile cb = + send_to_slave ?fail (Download_dir_find0 (src, remotedir, localfile, cb)) +let download_dir_tarball ?fail src remotedir format localfile cb = + send_to_slave ?fail + (Download_dir_tarball (src, remotedir, format, localfile, cb)) +let download_file ?fail src remotefile localfile cb = + send_to_slave ?fail (Download_file (src, remotefile, localfile, cb)) let open_domain ?fail name cb = send_to_slave ?fail (Open_domain (name, cb)) let open_images ?fail images cb = send_to_slave ?fail (Open_images (images, cb)) let read_directory ?fail src path cb = @@ -238,6 +269,35 @@ and execute_command = function let doms = List.sort ~cmp doms in callback_if_not_discarded cb doms + | Download_dir_find0 (src, remotedir, localfile, cb) -> + let g = get_g () in + with_mount_ro g src ( + fun () -> + g#find0 remotedir localfile + ); + callback_if_not_discarded cb () + + | Download_dir_tarball (src, remotedir, format, localfile, cb) -> + let g = get_g () in + let f = match format with + | Tar -> g#tar_out + | TGZ -> g#tgz_out + | TXZ -> g#txz_out + in + with_mount_ro g src ( + fun () -> + f remotedir localfile + ); + callback_if_not_discarded cb () + + | Download_file (src, remotefile, localfile, cb) -> + let g = get_g () in + with_mount_ro g src ( + fun () -> + g#download remotefile localfile + ); + callback_if_not_discarded cb () + | Open_domain (name, cb) -> let conn = get_conn () in let dom = D.lookup_by_name conn name in @@ -360,6 +420,8 @@ and open_disk_images images cb = g := Some g'; let g = g' in + g#set_trace (trace ()); + (* Uncomment the next line to pass the verbose flag from the command * line through to libguestfs. This is not generally necessary since * we are not so interested in debugging libguestfs problems at this diff --git a/slave.mli b/slave.mli index 940de14..a2725ea 100644 --- a/slave.mli +++ b/slave.mli @@ -154,6 +154,26 @@ val read_directory : ?fail:exn callback -> source -> string -> direntry list cal If [fail] is passed, then failures cause this callback to be called. If not, the global failure hook is called. *) +val download_file : ?fail:exn callback -> source -> string -> string -> unit callback -> unit + (** [download_file src pathname localfile cb] downloads [pathname] + to the named local file, and then calls the callback function. *) + +type download_dir_tarball_format = Tar | TGZ | TXZ + +val download_dir_tarball : ?fail:exn callback -> source -> string -> download_dir_tarball_format -> string -> unit callback -> unit + (** [download_dir_tarball_format src pathname format localfile cb] + downloads directory [pathname] to the named local file (a + tarball), and then calls the callback function. + + [format] controls the download format, which is one of + uncompressed tar, gzip-compressed tar, or xz-compressed tar. *) + +val download_dir_find0 : ?fail:exn callback -> source -> string -> string -> unit callback -> unit + (** [download_dir_find0 src pathname localfile cb] downloads the + list of filenames of directory [pathname] to the named local + file (a ASCII NUL-separated text file), and then calls the + callback function. *) + val discard_command_queue : unit -> unit (** [discard_command_queue ()] discards any commands on the command queue. diff --git a/utils.ml b/utils.ml index 9b6f3bd..8ad67c4 100644 --- a/utils.ml +++ b/utils.ml @@ -49,6 +49,14 @@ let failwith fs = in ksprintf f fs +let trace = ref false +let set_trace_flag () = trace := true +let trace () = !trace + +let connect_uri = ref None +let set_connect_uri conn = connect_uri := conn +let connect_uri () = !connect_uri + let utf8_rarrow = "\xe2\x86\x92" let human_size_1k i = diff --git a/utils.mli b/utils.mli index 6479fea..3e93755 100644 --- a/utils.mli +++ b/utils.mli @@ -43,6 +43,18 @@ val failwith : ('a, unit, string, 'b) format4 -> 'a take a printf-like argument list, and also logs errors on stderr when verbose is enabled. *) +val trace : unit -> bool +val set_trace_flag : unit -> unit + (** If this contains [true] then calls to libguestfs are traced. + + This is set through the [-x] command line option. *) + +val connect_uri : unit -> string option +val set_connect_uri : string option -> unit + (** The libvirt connection URI. + + This is set through the [--connect] command line option. *) + val utf8_rarrow : string (** UTF-8 RIGHTWARDS ARROW *) val human_size_1k : int64 -> string diff --git a/window.ml b/window.ml index c4e17b0..5f3852a 100644 --- a/window.ml +++ b/window.ml @@ -61,6 +61,9 @@ and when_connected ws uri doms = | None -> set_statusbar ws "Connected to default libvirt" | Some uri -> set_statusbar ws (sprintf "Connected to %s" uri) ); + populate_vmcombo ws doms + +and populate_vmcombo ws doms = (* Populate the VM combo box. *) let combo, (model, column) = ws.vmcombo in model#clear (); @@ -204,6 +207,9 @@ let rec open_main_window () = ) ); + Filetree.set_status_fn view (set_statusbar ws); + + (* Return the window_state struct. *) ws and make_menubar window vbox ~packing () = @@ -257,3 +263,29 @@ and make_filetree ~packing () = let sw = GBin.scrolled_window ~packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in Filetree.create ~packing:sw#add () + +(* Do what the user asked on the command line. *) +let rec run_cli_request ws = function + | Cmdline.Empty_window -> () + | Cmdline.Open_images images -> + open_disk_images ws images + | Cmdline.Open_guest guest -> + (* Open libvirt connection, and in the callback open the guest. *) + let uri = connect_uri () in + Slave.connect uri (when_connected_cli_request ws guest) +and when_connected_cli_request ws guest doms = + populate_vmcombo ws doms; + + (* "guest" should match a domain in "doms". Check this and + * get the index of it. + *) + let rec loop i = function + | [] -> + failwith "guest %s not found (do you need to use --connect?)" guest + | d::ds when d = guest -> i + | _::ds -> loop (i+1) ds + in + let i = loop 0 (List.map (fun { Slave.dom_name = name } -> name) doms) in + + let combo, _ = ws.vmcombo in + combo#set_active i diff --git a/window.mli b/window.mli index b91ccd9..2ebbeba 100644 --- a/window.mli +++ b/window.mli @@ -38,9 +38,7 @@ val throbber_idle : window_state -> unit -> unit val progress : window_state -> int64 * int64 -> unit (** This called whenever the progress bar should move. *) -(* - val run_cli_request : window_state -> Cmdline.cli_request -> unit -(** This function performs the {!Cmdline.cli_request} operation. - The actual operation happens asynchronously after this function - has returned. *) -*) +val run_cli_request : window_state -> Cmdline.cli_request -> unit + (** This function performs the {!Cmdline.cli_request} operation. + The actual operation happens asynchronously after this function + has returned. *) -- 1.8.3.1