From: Richard W.M. Jones Date: Fri, 17 Dec 2010 20:13:25 +0000 (+0000) Subject: Version 0.1.4. X-Git-Tag: 0.1.4^0 X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=2c3c52f43760f7ce8a27659540fbae3ad2f682b2;p=guestfs-browser.git Version 0.1.4. --- diff --git a/.depend b/.depend index a2f2dac..a43d14c 100644 --- a/.depend +++ b/.depend @@ -7,28 +7,34 @@ config.cmx: config.cmi deviceSet.cmi: deviceSet.cmo: deviceSet.cmi deviceSet.cmx: deviceSet.cmi -filetree.cmi: slave.cmi -filetree.cmo: utils.cmi slave.cmi filetree_type.cmi filetree_ops.cmi filetree_markup.cmi deviceSet.cmi filetree.cmi -filetree.cmx: utils.cmx slave.cmx filetree_type.cmx filetree_ops.cmx filetree_markup.cmx deviceSet.cmx filetree.cmi -filetree_markup.cmi: slave.cmi filetree_type.cmi -filetree_markup.cmo: utils.cmi slave.cmi filetree_type.cmi filetree_markup.cmi -filetree_markup.cmx: utils.cmx slave.cmx filetree_type.cmx filetree_markup.cmi -filetree_ops.cmi: slave.cmi filetree_type.cmi -filetree_ops.cmo: utils.cmi slave.cmi filetree_type.cmi filetree_markup.cmi filetree_ops.cmi -filetree_ops.cmx: utils.cmx slave.cmx filetree_type.cmx filetree_markup.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 +filetree.cmi: slave_types.cmi +filetree.cmo: utils.cmi slave_types.cmi slave.cmi filetree_type.cmi filetree_ops.cmi filetree_markup.cmi deviceSet.cmi config.cmi filetree.cmi +filetree.cmx: utils.cmx slave_types.cmx slave.cmx filetree_type.cmx filetree_ops.cmx filetree_markup.cmx deviceSet.cmx config.cmx filetree.cmi +filetree_markup.cmi: slave_types.cmi filetree_type.cmi +filetree_markup.cmo: utils.cmi slave_types.cmi filetree_type.cmi filetree_markup.cmi +filetree_markup.cmx: utils.cmx slave_types.cmx filetree_type.cmx filetree_markup.cmi +filetree_ops.cmi: slave_types.cmi filetree_type.cmi +filetree_ops.cmo: utils.cmi slave_types.cmi slave.cmi filetree_type.cmi filetree_markup.cmi filetree_ops.cmi +filetree_ops.cmx: utils.cmx slave_types.cmx slave.cmx filetree_type.cmx filetree_markup.cmx filetree_ops.cmi +filetree_type.cmi: slave_types.cmi slave.cmi +filetree_type.cmo: utils.cmi slave_types.cmi slave.cmi filetree_type.cmi +filetree_type.cmx: utils.cmx slave_types.cmx slave.cmx filetree_type.cmi main.cmo: window.cmi utils.cmi slave.cmi config.cmi cmdline.cmi main.cmx: window.cmx utils.cmx slave.cmx config.cmx cmdline.cmx -slave.cmi: -slave.cmo: utils.cmi slave.cmi -slave.cmx: utils.cmx slave.cmi +slave.cmi: slave_types.cmi +slave.cmo: utils.cmi slave_utils.cmi slave_types.cmi slave.cmi +slave.cmx: utils.cmx slave_utils.cmx slave_types.cmx slave.cmi +slave_types.cmi: +slave_types.cmo: slave_types.cmi +slave_types.cmx: slave_types.cmi +slave_utils.cmi: slave_types.cmi +slave_utils.cmo: utils.cmi slave_types.cmi slave_utils.cmi +slave_utils.cmx: utils.cmx slave_types.cmx slave_utils.cmi throbber.cmo: throbber.cmx: utils.cmi: utils.cmo: config.cmi utils.cmi utils.cmx: config.cmx utils.cmi window.cmi: cmdline.cmi -window.cmo: utils.cmi throbber.cmo slave.cmi filetree.cmi cmdline.cmi window.cmi -window.cmx: utils.cmx throbber.cmx slave.cmx filetree.cmx cmdline.cmx window.cmi +window.cmo: utils.cmi throbber.cmo slave_types.cmi slave.cmi filetree.cmi cmdline.cmi window.cmi +window.cmx: utils.cmx throbber.cmx slave_types.cmx slave.cmx filetree.cmx cmdline.cmx window.cmi diff --git a/HACKING b/HACKING index 28b25f7..7cd3f2d 100644 --- a/HACKING +++ b/HACKING @@ -65,7 +65,7 @@ Most modules alias short names for some common libvirt and libguestfs modules, eg: module C = Libvirt.Connect - module Q = Queue + module G = Guestfs So when you see a function such as 'C.connect_readonly', it's really the function 'connect_readonly' in the [nested] module diff --git a/Makefile.am b/Makefile.am index 7bae6e6..552abe8 100644 --- a/Makefile.am +++ b/Makefile.am @@ -26,7 +26,7 @@ EXTRA_DIST = \ guestfs-browser.1 \ html/pod.css -CLEANFILES = *.cmi *.cmo *.cmx *.o guestfs-browser +CLEANFILES = *.cmi *.cmo *.cmx *.o guestfs-browser *~ # These are listed here in alphabetical order. SOURCES = \ @@ -47,6 +47,10 @@ SOURCES = \ main.ml \ slave.mli \ slave.ml \ + slave_types.mli \ + slave_types.ml \ + slave_utils.mli \ + slave_utils.ml \ throbber.ml \ utils.mli \ utils.ml \ @@ -60,6 +64,8 @@ OBJECTS = \ utils.cmx \ cmdline.cmx \ deviceSet.cmx \ + slave_types.cmx \ + slave_utils.cmx \ slave.cmx \ filetree_type.cmx \ filetree_markup.cmx \ diff --git a/config.ml.in b/config.ml.in index 667c00d..74773a5 100644 --- a/config.ml.in +++ b/config.ml.in @@ -18,3 +18,8 @@ let package = "@PACKAGE_NAME@" let version = "@PACKAGE_VERSION@" + +let hivexregedit = "@HIVEXREGEDIT@" +let hivexregedit = if hivexregedit <> "no" then Some hivexregedit else None +let opener = "@OPENER@" +let opener = if opener <> "no" then Some opener else None diff --git a/config.mli b/config.mli index 7bfc623..d83b673 100644 --- a/config.mli +++ b/config.mli @@ -25,3 +25,9 @@ val package : string (** The package name. *) val version : string (** The version number as a string. *) + +val hivexregedit : string option + (** External hivexregedit program, or None if not available. *) + +val opener : string option + (** External program for viewing files, or None if not available. *) diff --git a/configure.ac b/configure.ac index 67272ef..e88fb41 100644 --- a/configure.ac +++ b/configure.ac @@ -15,7 +15,7 @@ dnl You should have received a copy of the GNU General Public License along dnl with this program; if not, write to the Free Software Foundation, Inc., dnl 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -AC_INIT([guestfs-browser],[0.1.3]) +AC_INIT([guestfs-browser],[0.1.4]) AM_INIT_AUTOMAKE([foreign]) AC_CONFIG_MACRO_DIR([m4]) @@ -87,9 +87,15 @@ dnl Check for gdk_pixbuf_mlsource program. AC_PATH_PROGS([GDK_PIXBUF_MLSOURCE], [gdk_pixbuf_mlsource]) dnl Optional programs. + +dnl XXX Other desktop environments? +AC_CHECK_PROGS([OPENER], [gnome-open], [no]) + +AC_CHECK_PROG([HIVEXREGEDIT], [hivexregedit], [hivexregedit], [no]) + AC_CHECK_PROG(PERLDOC,[perldoc],[perldoc],[no]) if test "x$PERLDOC" = "xno" ; then - AC_MSG_WARN([perldoc not found - install perl to make man pages]) + AC_MSG_WARN([perldoc not found - install perl to make man pages]) fi AM_CONDITIONAL(HAVE_PERLDOC,[test "$perldoc" != "no"]) diff --git a/filetree.ml b/filetree.ml index 2bf0b3d..275c868 100644 --- a/filetree.ml +++ b/filetree.ml @@ -23,6 +23,7 @@ open Printf open Utils open DeviceSet +open Slave_types open Filetree_type open Filetree_markup @@ -32,8 +33,8 @@ module G = Guestfs type t = Filetree_type.t -(* Temporary directory for shared use by all instances of this widget, - * cleaned up when the program exits. +(* Temporary directory for shared use by any function in this file. + * It is cleaned up when the program exits. *) let tmpdir = tmpdir () @@ -171,10 +172,19 @@ and make_context_menu t paths = let factory = new GMenu.factory menu in let rec add_file_items path = + let item = factory#add_item "View ..." in + (match Config.opener with + | Some opener -> + ignore (item#connect#activate ~callback:(view_file t path opener)); + | None -> + item#misc#set_sensitive false + ); 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 (item#connect#activate ~callback:(file_information t path)); + let item = factory#add_item "MD5 checksum" in + ignore (item#connect#activate ~callback:(checksum_file t path "md5")); + let item = factory#add_item "SHA1 checksum" in + ignore (item#connect#activate ~callback:(checksum_file t path "sha1")); ignore (factory#add_separator ()); let item = factory#add_item "Download ..." in ignore (item#connect#activate ~callback:(download_file t path)); @@ -189,13 +199,13 @@ and make_context_menu t paths = 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)); + ~callback:(download_dir_tarball t Tar path)); let item = factory#add_item "Download as .tar.gz ..." in ignore (item#connect#activate - ~callback:(download_dir_tarball t Slave.TGZ path)); + ~callback:(download_dir_tarball t TGZ path)); let item = factory#add_item "Download as .tar.xz ..." in ignore (item#connect#activate - ~callback:(download_dir_tarball t Slave.TXZ path)); + ~callback:(download_dir_tarball t TXZ path)); let item = factory#add_item "Download list of filenames ..." in ignore (item#connect#activate ~callback:(download_dir_find0 t path)); @@ -221,7 +231,13 @@ and make_context_menu t paths = and add_regkey_items path = let item = factory#add_item "Download as .reg file ..." in - item#misc#set_sensitive false + (match Config.hivexregedit with + | Some hivexregedit -> + ignore (item#connect#activate + ~callback:(download_as_reg t path hivexregedit)); + | None -> + item#misc#set_sensitive false + ) and add_regvalue_items path = let item = factory#add_item "Copy value to clipboard" in @@ -234,10 +250,10 @@ and make_context_menu t paths = | [] -> false (* single selection *) - | [path, { content=Top (Slave.OS os)} ] -> (* top level operating system *) + | [path, { content=Top (OS os)} ] -> (* top level operating system *) add_top_os_items path; true - | [path, { content=Top (Slave.Volume dev) }] -> (* top level volume *) + | [path, { content=Top (Volume dev) }] -> (* top level volume *) add_top_volume_items path; true | [path, { content=Directory _ }] -> (* directory *) @@ -278,14 +294,14 @@ let rec add ({ model = model } as t) name data = * filesystems. *) let other_filesystems = - DeviceSet.of_list (List.map fst data.Slave.insp_all_filesystems) in + DeviceSet.of_list (List.map fst data.insp_all_filesystems) in let other_filesystems = - List.fold_left (fun set { Slave.insp_filesystems = fses } -> + List.fold_left (fun set { insp_filesystems = fses } -> DeviceSet.subtract set (DeviceSet.of_array fses)) - other_filesystems data.Slave.insp_oses in + other_filesystems data.insp_oses in (* Add top level operating systems. *) - List.iter (add_top_level_os t name) data.Slave.insp_oses; + List.iter (add_top_level_os t name) data.insp_oses; (* Add top level left-over filesystems. *) DeviceSet.iter (add_top_level_vol t name) other_filesystems; @@ -295,35 +311,35 @@ let rec add ({ model = model } as t) name data = *) List.iter ( fun os -> - (match os.Slave.insp_winreg_SAM with + (match os.insp_winreg_SAM with | Some filename -> add_top_level_winreg t name os "HKEY_LOCAL_MACHINE\\SAM" filename | None -> () ); - (match os.Slave.insp_winreg_SECURITY with + (match os.insp_winreg_SECURITY with | Some filename -> add_top_level_winreg t name os "HKEY_LOCAL_MACHINE\\SECURITY" filename | None -> () ); - (match os.Slave.insp_winreg_SOFTWARE with + (match os.insp_winreg_SOFTWARE with | Some filename -> add_top_level_winreg t name os "HKEY_LOCAL_MACHINE\\SOFTWARE" filename | None -> () ); - (match os.Slave.insp_winreg_SYSTEM with + (match os.insp_winreg_SYSTEM with | Some filename -> add_top_level_winreg t name os "HKEY_LOCAL_MACHINE\\SYSTEM" filename | None -> () ); - (match os.Slave.insp_winreg_DEFAULT with + (match os.insp_winreg_DEFAULT with | Some filename -> add_top_level_winreg t name os "HKEY_USERS\\.DEFAULT" filename | None -> () ); - ) data.Slave.insp_oses; + ) data.insp_oses; (* Expand the first top level node. *) match model#get_iter_first with @@ -335,11 +351,11 @@ let rec add ({ model = model } as t) name data = and add_top_level_os ({ model = model } as t) name os = let markup = sprintf "%s\n%s\n%s" - (markup_escape name) (markup_escape os.Slave.insp_hostname) - (markup_escape os.Slave.insp_product_name) in + (markup_escape name) (markup_escape os.insp_hostname) + (markup_escape os.insp_product_name) in let row = model#append () in - make_node t row (Top (Slave.OS os)) None; + make_node t row (Top (OS os)) None; model#set ~row ~column:t.name_col markup (* Add a top level volume (left over filesystem) node. *) @@ -349,7 +365,7 @@ and add_top_level_vol ({ model = model } as t) name dev = (markup_escape dev) (markup_escape name) in let row = model#append () in - make_node t row (Top (Slave.Volume dev)) None; + make_node t row (Top (Volume dev)) None; model#set ~row ~column:t.name_col markup (* Add a top level Windows Registry node. *) @@ -363,7 +379,7 @@ and add_top_level_winreg ({ model = model } as t) name os rootkey let row = model#append () in make_node t row - (TopWinReg (Slave.OS os, rootkey, remotefile, cachefile)) None; + (TopWinReg (OS os, rootkey, remotefile, cachefile)) None; model#set ~row ~column:t.name_col markup (* Generic function to make an openable node to the tree. *) @@ -429,8 +445,8 @@ and expand_row ({ model = model } as t) row _ = (* Since the user has opened this top level registry node for the * first time, we now need to download the hive. *) - Slave.download_file ~fail:(when_downloaded_registry_fail t path) - src remotefile cachefile (when_downloaded_registry t path) + cache_registry_file ~fail:(when_downloaded_registry_fail t path) + t path src remotefile cachefile (when_downloaded_registry t path) | { state=NodeNotStarted; content=RegKey node } as hdata -> (* User has opened a Windows Registry key node not previously opened. *) @@ -443,8 +459,10 @@ and expand_row ({ model = model } as t) row _ = (* Ignore when a user opens a node which is loading or has been loaded. *) | { state=(NodeLoading|IsNode) } -> () - (* These are not nodes so it should never be possible to open them. *) - | { content=(File _ | RegValue _) } | { state=IsLeaf } -> assert false + (* In some circumstances these can be nodes, eg. if we have added Info + * nodes below them. Just ignore them if opened. + *) + | { content=(File _ | RegValue _) } | { state=IsLeaf } -> () (* Node should not exist in the tree. *) | { state=NodeNotStarted; content=(Loading | ErrorMessage _ | Info _) } -> @@ -457,7 +475,7 @@ and when_read_directory ({ model = model } as t) path entries = let row = model#get_iter path in (* Sort the entries by lexicographic ordering. *) - let cmp { Slave.dent_name = n1 } { Slave.dent_name = n2 } = + let cmp { dent_name = n1 } { dent_name = n2 } = UTF8.compare n1 n2 in let entries = List.sort ~cmp entries in @@ -465,7 +483,7 @@ and when_read_directory ({ model = model } as t) path entries = (* Add the entries. *) List.iter ( fun direntry -> - let { Slave.dent_name = name; dent_stat = stat; dent_link = link } = + let { 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 @@ -522,23 +540,12 @@ and when_read_directory_fail ({ model = model } as t) path exn = and when_downloaded_registry ({ model = model } as t) path () = debug "when_downloaded_registry"; let row = model#get_iter path in - let hdata = get_hdata t row in - match hdata.content with - | TopWinReg (src, rootkey, remotefile, cachefile) -> - (try - (* Open the hive and save the hive handle in the row hdata. *) - let flags = if verbose () then [ Hivex.OPEN_VERBOSE ] else [] in - let h = Hivex.open_file cachefile flags in - hdata.hiveh <- Some h; - - (* Continue as if expanding any other hive node. *) - let root = Hivex.root h in - expand_hive_node t row root - with - Hivex.Error _ as exn -> when_downloaded_registry_fail t path exn - ) - | _ -> assert false + let h = Option.get hdata.hiveh in + + (* Continue as if expanding any other hive node. *) + let root = Hivex.root h in + expand_hive_node t row root (* Called instead of {!when_downloaded_registry} if the download failed. *) and when_downloaded_registry_fail ({ model = model } as t) path exn = diff --git a/filetree.mli b/filetree.mli index 4bb2c30..9730fef 100644 --- a/filetree.mli +++ b/filetree.mli @@ -38,7 +38,7 @@ val create : packing:(GObj.widget -> unit) -> unit -> t val clear : t -> unit (** Clear out all rows in existing widget. *) -val add : t -> string -> Slave.inspection_data -> unit +val add : t -> string -> Slave_types.inspection_data -> unit (** [add t name data] clears out the widget and adds the operating system and/or filesystems described by the [data] struct. diff --git a/filetree_markup.ml b/filetree_markup.ml index a890cca..ebae98b 100644 --- a/filetree_markup.ml +++ b/filetree_markup.ml @@ -23,6 +23,7 @@ open Default.Camomile open Unix open Utils +open Slave_types open Filetree_type open Printf @@ -47,15 +48,15 @@ let other_color = file_color (* anything not one of the above *) * http://library.gnome.org/devel/pango/stable/PangoMarkupFormat.html *) let rec markup_of_name ?(visited = false) direntry = - let name = direntry.Slave.dent_name in - let mode = direntry.Slave.dent_stat.Guestfs.mode in + let name = direntry.dent_name in + let mode = direntry.dent_stat.Guestfs.mode in if is_directory mode then ( (* directory *) let fg = if not visited then normal dir_color else darken dir_color in sprintf "%s" fg (markup_escape name) ) else if is_symlink mode then ( (* symlink *) - let link = direntry.Slave.dent_link in + let link = direntry.dent_link in let fg = if not visited then normal symlink_color else darken symlink_color in sprintf "%s %s %s" @@ -212,7 +213,7 @@ let set_visited ({ model = model; name_col = name_col } as t) row = hdata.visited <- true; match hdata.content with | Directory direntry | File direntry -> - debug "set_visited %s" direntry.Slave.dent_name; + debug "set_visited %s" direntry.dent_name; model#set ~row ~column:name_col (markup_of_name ~visited:true direntry) | RegKey node -> diff --git a/filetree_markup.mli b/filetree_markup.mli index de4cfb4..f3d9083 100644 --- a/filetree_markup.mli +++ b/filetree_markup.mli @@ -25,7 +25,7 @@ (**/**) -val markup_of_name : ?visited:bool -> Slave.direntry -> string +val markup_of_name : ?visited:bool -> Slave_types.direntry -> string (* Create markup for filenames. *) val markup_of_date : int64 -> string diff --git a/filetree_ops.ml b/filetree_ops.ml index 801f50a..dcea59d 100644 --- a/filetree_ops.ml +++ b/filetree_ops.ml @@ -19,9 +19,16 @@ open Printf open Utils +open Slave_types + open Filetree_type open Filetree_markup +(* Temporary directory for shared use by any function in this file. + * It is cleaned up when the program exits. + *) +let tmpdir = tmpdir () + (* 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. @@ -35,6 +42,19 @@ let basename pathname = with Not_found -> pathname +(* Get the extension of a file using libguestfs path conventions, + * including the leading point (eg. ".txt"). Might return an empty + * string if there is no extension. + *) +let extension pathname = + let len = String.length pathname in + try + let i = String.rindex pathname '.' in + let r = String.sub pathname i (len-i) in + r + with + Not_found -> "" + (* Download a single file. *) let rec download_file ({ model = model } as t) path () = let row = model#get_iter path in @@ -78,9 +98,9 @@ let rec download_dir_tarball ({ model = model } as t) format path () = dlg#add_select_button_stock `SAVE `SAVE; let extension = match format with - | Slave.Tar -> ".tar" - | Slave.TGZ -> ".tar.gz" - | Slave.TXZ -> ".tar.xz" + | Tar -> ".tar" + | TGZ -> ".tar.gz" + | TXZ -> ".tar.xz" in dlg#set_current_name (basename pathname ^ extension); @@ -170,7 +190,7 @@ let rec disk_usage ({ model = model } as t) path () = and when_disk_usage ({ model = model } as t) path pathname kbytes = let row = model#get_iter path in - (* Find the Info "disk_usage" child node add above, and replace the + (* Find the Info "disk_usage" child node added above, and replace the * text in it with the final size. *) try @@ -193,8 +213,8 @@ let display_inspection_data ({ model = model } as t) path () = (* Should be an OS source, if not ignore. *) match src with - | Slave.Volume _ -> () - | Slave.OS os -> + | Volume _ -> () + | OS os -> (* See if this node already has an Info "inspection_data" child * node. If so they don't recreate it. *) @@ -208,20 +228,20 @@ let display_inspection_data ({ model = model } as t) path () = (* XXX UGHLEE *) let data = sprintf "Type: %s\nDistro: %s\nVersion: %d.%d\nArch.: %s\nPackaging: %s/%s\n%sMountpoints:\n%s" - os.Slave.insp_type os.Slave.insp_distro - os.Slave.insp_major_version os.Slave.insp_minor_version - os.Slave.insp_arch - os.Slave.insp_package_management os.Slave.insp_package_format - (match os.Slave.insp_windows_systemroot with + os.insp_type os.insp_distro + os.insp_major_version os.insp_minor_version + os.insp_arch + os.insp_package_management os.insp_package_format + (match os.insp_windows_systemroot with | None -> "" | Some path -> - sprintf "%%systemroot%%: %s\n" (markup_escape path)) + sprintf "Systemroot: %s\n" (markup_escape path)) (String.concat "\n" (List.map ( fun (mp, dev) -> sprintf "%s on %s" (markup_escape dev) (markup_escape mp)) - os.Slave.insp_mountpoints) + os.insp_mountpoints) ) in model#set ~row ~column:t.name_col data @@ -239,3 +259,152 @@ let copy_regvalue ({ model = model } as t) path () = cb#set_text v | _ -> () (* not a registry value row, ignore *) + +(* View a single file. *) +let rec view_file ({ model = model } as t) path opener () = + let row = model#get_iter path in + let src, pathname = get_pathname t row in + debug "view_file %s" pathname; + + (* Download the file into a temporary directory. *) + let ext = extension pathname in + let localfile = tmpdir // string_of_int (unique ()) ^ ext in + Slave.download_file src pathname localfile + (when_downloaded_file_for_view t path opener localfile) + +and when_downloaded_file_for_view ({ model = model } as t) path + opener localfile () = + let row = model#get_iter path in + set_visited t row; + + let cmd = + sprintf "%s %s" (Filename.quote opener) (Filename.quote localfile) in + Slave.run_command cmd Slave.no_callback + +(* Compute the checksum of a file. *) +let rec checksum_file ({ model = model } as t) path csumtype () = + let row = model#get_iter path in + let src, pathname = get_pathname t row in + debug "checksum_file %s" pathname; + + (* See if this node already has an Info "checksum" child + * node. If so they don't recreate it. + *) + let content = Info ("checksum:" ^ csumtype) in + if not (has_child_node_equals t row content) then ( + let row = model#insert ~parent:row 0 in + let hdata = + { state=IsLeaf; content=content; visited=false; hiveh=None } in + store_hdata t row hdata; + model#set ~row ~column:t.name_col + (sprintf "Calculating %s ..." csumtype); + + t.view#expand_row path; + + Slave.checksum_file src pathname csumtype + (when_checksum_file t path pathname csumtype) + ) + +and when_checksum_file ({ model = model } as t) path pathname csumtype checksum= + let row = model#get_iter path in + set_visited t row; + + (* Find the child node added above, and replace the text. *) + try + let content = Info ("checksum:" ^ csumtype) in + let row = find_child_node_by_content t row content in + let msg = sprintf "%s: %s" csumtype checksum in + model#set ~row ~column:t.name_col msg + with + Not_found -> () + +(* Compute the file information of a file. *) +let rec file_information ({ model = model } as t) path () = + let row = model#get_iter path in + let src, pathname = get_pathname t row in + debug "file_information %s" pathname; + + (* See if this node already has an Info "file_information" child + * node. If so they don't recreate it. + *) + let content = Info "file_information" in + if not (has_child_node_equals t row content) then ( + let row = model#insert ~parent:row 0 in + let hdata = + { state=IsLeaf; content=content; visited=false; hiveh=None } in + store_hdata t row hdata; + model#set ~row ~column:t.name_col "Calculating file information ..."; + + t.view#expand_row path; + + Slave.file_information src pathname (when_file_information t path pathname) + ) + +and when_file_information ({ model = model } as t) path pathname info = + let row = model#get_iter path in + set_visited t row; + + (* Find the child node added above, and replace the text. *) + try + let content = Info "file_information" in + let row = find_child_node_by_content t row content in + model#set ~row ~column:t.name_col (markup_escape info) + with + Not_found -> () + +(* Export a registry key/subkey tree as a reg file. This is pretty + * effortless with hivexregedit. + *) +let download_as_reg ({ model = model } as t) path hivexregedit () = + let row = model#get_iter path in + let hdata = get_hdata t row in + + (* Get path to the top of the registry tree. *) + let (_, rootkey, _, cachefile), nodes = get_registry_path t row in + let regpath = String.concat "\\" (List.rev nodes) in + debug "download_as_reg: %s %s %s" cachefile rootkey regpath; + + let do_dialog () = + (* Put up the dialog. *) + let title = "Download as .reg 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 name = match nodes with [] -> rootkey | (name::_) -> name in + dlg#set_current_name (name ^ ".reg"); + + match dlg#run () with + | `DELETE_EVENT | `CANCEL -> + dlg#destroy () + | `SAVE -> + match dlg#filename with + | None -> () + | Some localfile -> + dlg#destroy (); + + (* Use hivexregedit to save it. *) + let cmd = + sprintf "%s --export --prefix %s %s %s > %s" + (Filename.quote hivexregedit) + (Filename.quote rootkey) (Filename.quote cachefile) + (Filename.quote regpath) (Filename.quote localfile) in + Slave.run_command cmd Slave.no_callback + in + + match hdata with + | { content=RegKey _ } -> + do_dialog () + + | { content=TopWinReg (src, _, remotefile, cachefile) } -> + (* There's a subtle problem here: If the top node has not been + * opened, the registry cachefile won't have been downloaded. If + * the top node has been opened, the registry might still be + * being downloaded as we are running here. Either way we can't + * trust the cachefile. Tell the slave thread to download the + * file if it's not downloaded already (since the slave thread + * runs in a serial loop, this is always race free). + *) + cache_registry_file t path src remotefile cachefile do_dialog + + | _ -> () (* not a registry key, ignore *) diff --git a/filetree_ops.mli b/filetree_ops.mli index a30b390..34d2614 100644 --- a/filetree_ops.mli +++ b/filetree_ops.mli @@ -28,14 +28,22 @@ (**/**) +val checksum_file : Filetree_type.t -> Gtk.tree_path -> string -> unit -> unit + val copy_regvalue : Filetree_type.t -> Gtk.tree_path -> unit -> unit val disk_usage : Filetree_type.t -> Gtk.tree_path -> unit -> unit val display_inspection_data : Filetree_type.t -> Gtk.tree_path -> unit -> unit -val download_file : Filetree_type.t -> Gtk.tree_path -> unit -> unit +val download_as_reg : Filetree_type.t -> Gtk.tree_path -> string -> unit -> unit -val download_dir_tarball : Filetree_type.t -> Slave.download_dir_tarball_format -> Gtk.tree_path -> unit -> unit +val download_dir_tarball : Filetree_type.t -> Slave_types.download_dir_tarball_format -> Gtk.tree_path -> unit -> unit val download_dir_find0 : Filetree_type.t -> Gtk.tree_path -> unit -> unit + +val download_file : Filetree_type.t -> Gtk.tree_path -> unit -> unit + +val file_information : Filetree_type.t -> Gtk.tree_path -> unit -> unit + +val view_file : Filetree_type.t -> Gtk.tree_path -> string -> unit -> unit diff --git a/filetree_type.ml b/filetree_type.ml index f39137e..285677f 100644 --- a/filetree_type.ml +++ b/filetree_type.ml @@ -18,6 +18,8 @@ open Utils +open Slave_types + (* See struct/field description in .mli file. *) type t = { view : GTree.view; @@ -47,10 +49,10 @@ and content_t = | Loading | ErrorMessage of string | Info of string - | Top of Slave.source - | TopWinReg of Slave.source * string * string * string - | Directory of Slave.direntry - | File of Slave.direntry + | Top of source + | TopWinReg of source * string * string * string + | Directory of direntry + | File of direntry | RegKey of Hivex.node | RegValue of Hivex.value @@ -92,7 +94,8 @@ let find_child_node_by_content ({ model = model } as t) row c = * \_ Directory * \_ Loading <--- you are here * - * Note this function cannot be called on registry keys. + * Note this function cannot be called on registry keys. See + * {!get_registry_path} for that. *) let rec get_pathname ({ model = model } as t) row = let hdata = get_hdata t row in @@ -103,8 +106,8 @@ let rec get_pathname ({ model = model } as t) row = get_pathname t parent | { state=IsLeaf; content=(Loading|ErrorMessage _|Info _) }, None -> assert false - | { content=Directory { Slave.dent_name = name }}, Some parent - | { content=File { Slave.dent_name = name }}, Some parent -> + | { content=Directory { dent_name = name }}, Some parent + | { content=File { dent_name = name }}, Some parent -> let src, parent_name = get_pathname t parent in let path = if parent_name = "/" then "/" ^ name @@ -119,3 +122,67 @@ let rec get_pathname ({ model = model } as t) row = | { content=TopWinReg _ }, _ -> assert false | { content=RegKey _ }, _ -> assert false | { content=RegValue _ }, _ -> assert false + +(* Search up to the top of the tree from a registry key. + * + * The path up the tree will always look something like: + * TopWinReg + * \_ RegKey + * \_ RegKey <--- you are here + * \_ Loading <--- or here + * + * Note this function cannot be called on ordinary paths. Use + * {!get_pathname} for that. + *) +let rec get_registry_path ({ model = model } as t) row = + let hdata = get_hdata t row in + let parent = model#iter_parent row in + + match hdata, parent with + | { state=IsLeaf; content=(Loading|ErrorMessage _|Info _) }, Some parent -> + get_registry_path t parent + | { state=IsLeaf; content=(Loading|ErrorMessage _|Info _) }, None -> + assert false + | { content=RegKey node; hiveh = Some h }, Some parent -> + let top, path = get_registry_path t parent in + let path = Hivex.node_name h node :: path in + top, path + | { content=TopWinReg (a,b,c,d) }, None -> (a,b,c,d), [] + | { content=TopWinReg _ }, _ -> assert false + | { content=RegKey _}, _ -> assert false + | { content=Top _ }, _ -> assert false + | { content=Directory _ }, _ -> assert false + | { content=File _ }, _ -> assert false + | { content=Loading }, _ -> assert false + | { content=ErrorMessage _ }, _ -> assert false + | { content=Info _ }, _ -> assert false + | { content=RegValue _ }, _ -> assert false + +let rec cache_registry_file ?fail t path src remotefile cachefile cb = + Slave.download_file_if_not_exist ?fail src remotefile cachefile + (when_cached_registry ?fail t path cb) + +and when_cached_registry ?fail ({ model = model } as t) path cb () = + debug "when_cached_registry"; + let row = model#get_iter path in + let hdata = get_hdata t row in + + match hdata with + | { hiveh=Some _; content=TopWinReg _ } -> + (* Hive handle already opened. *) + cb () + + | { hiveh=None; content=TopWinReg (src, rootkey, remotefile, cachefile) } -> + (* Hive handle not opened, open it and save it in the handle. *) + (try + let flags = if verbose () then [ Hivex.OPEN_VERBOSE ] else [] in + let h = Hivex.open_file cachefile flags in + hdata.hiveh <- Some h; + cb () + with + Hivex.Error _ as exn -> + match fail with + | Some fail -> fail exn + | None -> raise exn + ) + | _ -> assert false diff --git a/filetree_type.mli b/filetree_type.mli index e1bd7da..b5c642a 100644 --- a/filetree_type.mli +++ b/filetree_type.mli @@ -62,11 +62,11 @@ and content_t = | Loading (* special "loading ..." node *) | ErrorMessage of string (* error message node *) | Info of string (* information node (eg. disk usage) *) - | Top of Slave.source (* top level OS or volume node *) + | Top of Slave_types.source (* top level OS or volume node *) (* top level Windows Registry node *) - | TopWinReg of Slave.source * string * string * string - | Directory of Slave.direntry (* a directory *) - | File of Slave.direntry (* a file inc. special files *) + | TopWinReg of Slave_types.source * string * string * string + | Directory of Slave_types.direntry(* a directory *) + | File of Slave_types.direntry (* a file inc. special files *) | RegKey of Hivex.node (* a registry key (like a dir) *) | RegValue of Hivex.value (* a registry value (like a file) *) @@ -80,7 +80,18 @@ val find_child_node_by_content : t -> Gtk.tree_iter -> content_t -> Gtk.tree_ite [hdata.content] and returns that child. If no child found, raises [Not_found]. *) -val get_pathname : t -> Gtk.tree_iter -> Slave.source * string +val get_pathname : t -> Gtk.tree_iter -> Slave_types.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 get_registry_path : t -> Gtk.tree_iter -> (Slave_types.source * string * string * string) * string list + (* Get the path to the top from a registry key. This returns the + pair [(TopWinReg_data, path)] where [TopWinReg_data] is the data + inside a {!TopWinReg} node, and [path] is the path (list of node + names) up to the top. You normally need to call {!List.rev} on + [path]. *) + +val cache_registry_file : ?fail:exn Slave.callback -> t -> Gtk.tree_path -> Slave_types.source -> string -> string -> unit Slave.callback -> unit + (* This is called whenever we need the registry cache file and we + can't be sure that it has already been downloaded. *) diff --git a/guestfs-browser.spec.in b/guestfs-browser.spec.in index 05dc733..790d844 100644 --- a/guestfs-browser.spec.in +++ b/guestfs-browser.spec.in @@ -29,6 +29,8 @@ BuildRequires: /usr/bin/pod2man BuildRequires: /usr/bin/pod2html Requires: libguestfs >= 1.7.24 +Requires: /usr/bin/gnome-open +Requires: /usr/bin/hivexregedit # Only needed to build the internal documentation. #BuildRequires: ocaml-ocamldoc diff --git a/slave.ml b/slave.ml index 01105ef..e605a21 100644 --- a/slave.ml +++ b/slave.ml @@ -23,6 +23,9 @@ open Default.Camomile open Utils +open Slave_types +open Slave_utils + open Printf module C = Libvirt.Connect @@ -37,59 +40,23 @@ type 'a callback = 'a -> unit (* The commands. *) type command = | Exit_thread + | Checksum_file of source * string * string * string callback | Connect of string option * domain list callback | Disk_usage of source * string * int64 callback | Download_dir_find0 of source * string * string * unit callback | Download_dir_tarball of source * string * download_dir_tarball_format * string * unit callback - | Download_file of source * string * string * unit callback + | Download_file of source * string * string * bool * unit callback + | File_information of source * string * string 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 - -and domain = { - dom_id : int; - dom_name : string; - dom_state : D.state; -} - -and inspection_data = { - insp_all_filesystems : (string * string) list; - insp_oses : inspection_os list; -} - -and inspection_os = { - insp_root : string; - insp_arch : string; - insp_distro : string; - insp_filesystems : string array; - insp_hostname : string; - insp_major_version : int; - insp_minor_version : int; - insp_mountpoints : (string * string) list; - insp_package_format : string; - insp_package_management : string; - insp_product_name : string; - insp_type : string; - insp_windows_systemroot : string option; - insp_winreg_DEFAULT : string option; - insp_winreg_SAM : string option; - insp_winreg_SECURITY : string option; - insp_winreg_SOFTWARE : string option; - insp_winreg_SYSTEM : string option; -} - -and source = OS of inspection_os | Volume of string - -and direntry = { - dent_name : string; - dent_stat : G.stat; - dent_link : string; -} - -and download_dir_tarball_format = Tar | TGZ | TXZ + | Run_command of string * unit callback let rec string_of_command = function | Exit_thread -> "Exit_thread" + | Checksum_file (src, pathname, csumtype, _) -> + sprintf "Checksum_file (%s, %s, %s)" + (string_of_source src) pathname csumtype | Connect (Some name, _) -> sprintf "Connect %s" name | Connect (None, _) -> "Connect NULL" | Disk_usage (src, remotedir, _) -> @@ -101,14 +68,18 @@ let rec string_of_command = function 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 + | Download_file (src, remotefile, localfile, check, _) -> + sprintf "Download_file (%s, %s, %s, %b)" + (string_of_source src) remotefile localfile check + | File_information (src, pathname, _) -> + sprintf "File_information (%s, %s)" (string_of_source src) pathname | Open_domain (name, _) -> sprintf "Open_domain %s" name | Open_images (images, _) -> sprintf "Open_images %s" (string_of_images images) | Read_directory (src, dir, _) -> sprintf "Read_directory (%s, %s)" (string_of_source src) dir + | Run_command (cmd, _) -> + sprintf "Run_command %s" cmd and string_of_images images = "[" ^ @@ -178,6 +149,8 @@ let discard_command_queue () = q_discard := true ) +let checksum_file ?fail src pathname csumtype cb = + send_to_slave ?fail (Checksum_file (src, pathname, csumtype, cb)) let connect ?fail uri cb = send_to_slave ?fail (Connect (uri, cb)) let disk_usage ?fail src remotedir cb = send_to_slave ?fail (Disk_usage (src, remotedir, cb)) @@ -187,11 +160,17 @@ 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)) + send_to_slave ?fail (Download_file (src, remotefile, localfile, false, cb)) +let download_file_if_not_exist ?fail src remotefile localfile cb = + send_to_slave ?fail (Download_file (src, remotefile, localfile, true, cb)) +let file_information ?fail src pathname cb = + send_to_slave ?fail (File_information (src, pathname, 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 = send_to_slave ?fail (Read_directory (src, path, cb)) +let run_command ?fail cmd cb = + send_to_slave ?fail (Run_command (cmd, cb)) (*----- Slave thread starts here -----*) @@ -212,27 +191,6 @@ let callback_if_not_discarded (cb : 'a callback) (arg : 'a) = if not discard then GtkThread.async cb arg -(* Call 'f ()' with source mounted read-only. Ensure that everything - * is unmounted even if an exception is thrown. - *) -let with_mount_ro g src (f : unit -> 'a) : 'a = - Std.finally (fun () -> g#umount_all ()) ( - fun () -> - (* Do the mount - could be OS or single volume. *) - (match src with - | Volume dev -> g#mount_ro dev "/"; - | OS { insp_mountpoints = mps } -> - (* Sort the mountpoint keys by length, shortest first. *) - let cmp (a,_) (b,_) = compare (String.length a) (String.length b) in - let mps = List.sort ~cmp mps in - (* Mount the filesystems. *) - List.iter ( - fun (mp, dev) -> g#mount_ro dev mp - ) mps - ); - f () - ) () - (* Update the status bar. *) let status fs = let f str = GtkThread.async !status_hook str in @@ -276,6 +234,19 @@ and execute_command = function quit := true; close_all () + | Checksum_file (src, pathname, csumtype, cb) -> + status "Calculating %s checksum of %s ..." csumtype pathname; + + let g = get_g () in + let r = + with_mount_ro g src ( + fun () -> + g#checksum csumtype pathname + ) in + + status "Finished calculating %s checksum of %s" csumtype pathname; + callback_if_not_discarded cb r + | Connect (name, cb) -> let printable_name = match name with None -> "default hypervisor" | Some uri -> uri in @@ -340,18 +311,33 @@ and execute_command = function status "Finished downloading %s" localfile; callback_if_not_discarded cb () - | Download_file (src, remotefile, localfile, cb) -> - status "Downloading %s to %s ..." remotefile localfile; + | Download_file (src, remotefile, localfile, check, cb) -> + if not check || not (local_file_exists localfile) then ( + status "Downloading %s to %s ..." remotefile localfile; - let g = get_g () in - with_mount_ro g src ( - fun () -> - g#download remotefile localfile - ); + let g = get_g () in + with_mount_ro g src ( + fun () -> + g#download remotefile localfile + ); - status "Finished downloading %s" localfile; + status "Finished downloading %s" localfile + ); callback_if_not_discarded cb () + | File_information (src, pathname, cb) -> + status "Calculating file information for %s ..." pathname; + + let g = get_g () in + let r = + with_mount_ro g src ( + fun () -> + g#file pathname + ) in + + status "Finished calculating file information for %s" pathname; + callback_if_not_discarded cb r + | Open_domain (name, cb) -> status "Opening %s ..." name; @@ -374,10 +360,9 @@ and execute_command = function with_mount_ro g src ( fun () -> let names = g#ls dir in (* sorted and without . and .. *) - let names = Array.to_list names in - let stats = lstatlist_wrapper g dir names in - let links = readlink_wrapper g dir names stats in - names, stats, links + let stats = lstatlist g dir names in + let links = readlinks g dir names (Array.of_list stats) in + Array.to_list names, stats, links ) in assert ( let n = List.length names in @@ -392,6 +377,16 @@ and execute_command = function status "Finished reading directory %s" dir; callback_if_not_discarded cb entries + | Run_command (cmd, cb) -> + status "Running %s ..." cmd; + + if Sys.command cmd <> 0 then + failwith "External command failed: %s" cmd; + + status "Finished %s ..." cmd; + + callback_if_not_discarded cb () + (* Expect to be connected, and return the current libvirt connection. *) and get_conn () = match !conn with @@ -600,135 +595,6 @@ and open_disk_images images cb = status "Finished opening disk"; callback_if_not_discarded cb data -(* guestfs_lstatlist has a "hidden" limit of the protocol message size. - * Call this function, but split the list of names into chunks. - *) -and lstatlist_wrapper g dir = function - | [] -> [] - | names -> - let names', names = List.take 1000 names, List.drop 1000 names in - let xs = g#lstatlist dir (Array.of_list names') in - let xs = Array.to_list xs in - xs @ lstatlist_wrapper g dir names - -(* For each entry which is a symlink, read the destination of the - * symlink. This is non-trivial because on Windows we cannot use - * readlink but need to instead parse the reparse data from NTFS. - *) -and readlink_wrapper g dir names stats = - (* Is the directory on an NTFS filesystem? *) - let dev = get_mounted_device g dir in - if g#vfs_type dev <> "ntfs" then ( - (* Not NTFS, use the fast g#readlinklist method. *) - let rec readlinklist_wrapper g dir = function - | [] -> [] - | names -> - let names', names = List.take 1000 names, List.drop 1000 names in - let xs = g#readlinklist dir (Array.of_list names') in - let xs = Array.to_list xs in - xs @ readlinklist_wrapper g dir names - in - readlinklist_wrapper g dir names - ) - else ( - (* NTFS: look up each symlink individually. *) - List.map ( - fun (name, stat) -> - if not (is_symlink stat.G.mode) then "" - else - let path = if dir = "/" then dir ^ name else dir ^ "/" ^ name in - try - let _, display = get_ntfs_reparse_data g path in - display - with exn -> - debug "get_ntfs_reparse_data: %s: failed: %s" - path (Printexc.to_string exn); - "?" - ) (List.combine names stats) - ) - -(* See: - * https://bugzilla.redhat.com/show_bug.cgi?id=663407 - * http://git.annexia.org/?p=libguestfs.git;a=commit;h=3a3836b933b80c4f9f2c767fda4f8b459f998db2 - * http://www.tuxera.com/community/ntfs-3g-advanced/junction-points-and-symbolic-links/ - * http://www.tuxera.com/community/ntfs-3g-advanced/extended-attributes/ - * http://www.codeproject.com/KB/winsdk/junctionpoints.aspx - *) -and get_ntfs_reparse_data g path = - let data = g#lgetxattr path "system.ntfs_reparse_data" in - let link, display = - bitmatch Bitstring.bitstring_of_string data with - (* IO_REPARSE_TAG_MOUNT_POINT *) - | { 0xa0000003_l : 32 : littleendian; - _ : 16 : littleendian; (* data length - ignore it *) - _ : 16 : littleendian; (* reserved *) - link_offset : 16 : littleendian; - link_len : 16 : littleendian; - display_offset : 16 : littleendian; - display_len : 16 : littleendian; - link : link_len * 8 : - string, offset (8 * (link_offset + 0x10)); - display : display_len * 8 : - string, offset (8 * (display_offset + 0x10)) } -> - (* These strings should always be valid UTF16LE, but the caller - * is prepared to catch any exception if this fails. - *) - let link = windows_string_to_utf8 link in - let display = windows_string_to_utf8 display in - link, display - | { 0xa0000003_l : 32 : littleendian } -> - invalid_arg ( - sprintf "%s: could not parse IO_REPARSE_TAG_MOUNT_POINT data" path - ) - - (* IO_REPARSE_TAG_SYMLINK *) - | { 0xa000000c_l : 32 : littleendian; - _ : 16 : littleendian; (* data length - ignore it *) - _ : 16 : littleendian; (* reserved *) - link_offset : 16 : littleendian; - link_len : 16 : littleendian; - display_offset : 16 : littleendian; - display_len : 16 : littleendian; - link : link_len * 8 : - string, offset (8 * (link_offset + 0x14)); - display : display_len * 8 : - string, offset (8 * (display_offset + 0x14)) } -> - let link = windows_string_to_utf8 link in - let display = windows_string_to_utf8 display in - link, display - | { 0xa000000c_l : 32 : littleendian } -> - invalid_arg ( - sprintf "%s: could not parse IO_REPARSE_TAG_SYMLINK data" path - ) - - | { i : 32 : littleendian } -> - invalid_arg ( - sprintf "%s: reparse data of type 0x%lx is not supported" path i - ) - | { _ } -> - invalid_arg (sprintf "%s: reparse data is too short" path) in - - link, display - -(* Given a path which is located somewhere on a mountpoint, return the - * device name. This works by using g#mountpoints and then looking for - * the mount path with the longest match. - *) -and get_mounted_device g path = - let mps = g#mountpoints () in - let mps = List.map ( - fun (dev, mp) -> - if String.starts_with path mp then dev, String.length mp else dev, 0 - ) mps in - let cmp (_,n1) (_,n2) = compare n2 n1 in - let mps = List.sort ~cmp mps in - match mps with - | [] -> - invalid_arg (sprintf "%s: not mounted" path) - | (_,0) :: _ -> - invalid_arg (sprintf "%s: not found on any filesystem" path) - | (dev,_) :: _ -> dev - (* Start up one slave thread. *) let slave_thread = Thread.create loop () diff --git a/slave.mli b/slave.mli index 406e9db..57ce332 100644 --- a/slave.mli +++ b/slave.mli @@ -63,14 +63,12 @@ val no_callback : 'a callback (** The main thread uses this as a callback if it doesn't care about the return value from a command. *) -type domain = { - dom_id : int; - dom_name : string; - dom_state : Libvirt.Domain.state; -} - (** List of domains as returned in the {!connect} callback. *) - -val connect : ?fail:exn callback -> string option -> domain list callback -> unit +val checksum_file : ?fail:exn callback -> Slave_types.source -> string -> string -> string callback -> unit + (** [checksum_file src pathname csumtype cb] calculates the checksum + of the file [pathname]. [csumtype] is one of the types + supported by libguestfs. *) + +val connect : ?fail:exn callback -> string option -> Slave_types.domain list callback -> unit (** [connect uri cb] causes the slave thread to disconnect from libvirt and connect to the libvirt [uri]. If this succeeds, then the list of all domains fetched from libvirt and [cb] is @@ -83,36 +81,39 @@ val connect : ?fail:exn callback -> string option -> domain list callback -> uni If [fail] is passed, then failures cause this callback to be called. If not, the global failure hook is called. *) -type inspection_data = { - insp_all_filesystems : (string * string) list; - (** see {!Guestfs.list_filesystems} *) - insp_oses : inspection_os list; - (** one entry per root (operating system), see {!Guestfs.inspect_os} *) -} - (** The inspection data returned in the callback from - {!open_domain} and {!open_images}. *) -and inspection_os = { - insp_root : string; (** see {!Guestfs.inspect_os} *) - insp_arch : string; - insp_distro : string; - insp_filesystems : string array; - insp_hostname : string; - insp_major_version : int; - insp_minor_version : int; - insp_mountpoints : (string * string) list; - insp_package_format : string; - insp_package_management : string; - insp_product_name : string; - insp_type : string; - insp_windows_systemroot : string option; - insp_winreg_DEFAULT : string option; (* registry files *) - insp_winreg_SAM : string option; - insp_winreg_SECURITY : string option; - insp_winreg_SOFTWARE : string option; - insp_winreg_SYSTEM : string option; -} - -val open_domain : ?fail:exn callback -> string -> inspection_data callback -> unit +val disk_usage : ?fail:exn callback -> Slave_types.source -> string -> int64 callback -> unit + (** [disk_usage src pathname cb] calculates the disk usage of + directory [pathname] and calls the callback with the answer + (size of {b kilobytes}). *) + +val download_dir_tarball : ?fail:exn callback -> Slave_types.source -> string -> Slave_types.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 -> Slave_types.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 download_file : ?fail:exn callback -> Slave_types.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. *) + +val download_file_if_not_exist : ?fail:exn callback -> Slave_types.source -> string -> string -> unit callback -> unit + (** Like {!download_file} except that if [localfile] already exists + then the download is skipped. You can use this to implement + caching of remote files. *) + +val file_information : ?fail:exn callback -> Slave_types.source -> string -> string callback -> unit + (** [file_information src pathname cb] calculates the file + information of the file [pathname]. *) + +val open_domain : ?fail:exn callback -> string -> Slave_types.inspection_data callback -> unit (** [open_domain name cb] retrieves the list of block devices for the libvirt domain [name], creates a libguestfs handle, adds those block devices, launches the handle, and performs @@ -127,7 +128,7 @@ val open_domain : ?fail:exn callback -> string -> inspection_data callback -> un If [fail] is passed, then failures cause this callback to be called. If not, the global failure hook is called. *) -val open_images : ?fail:exn callback -> (string * string option) list -> inspection_data callback -> unit +val open_images : ?fail:exn callback -> (string * string option) list -> Slave_types.inspection_data callback -> unit (** [open_images images cb] is like {!open_domain} except that it opens local disk image(s) directly. [images] is a list of [(filename, format)] pairs. @@ -135,17 +136,7 @@ val open_images : ?fail:exn callback -> (string * string option) list -> inspect If [fail] is passed, then failures cause this callback to be called. If not, the global failure hook is called. *) -type source = OS of inspection_os | Volume of string - (** Source type used by {!read_directory}. *) - -type direntry = { - dent_name : string; (** Basename in directory. *) - dent_stat : Guestfs.stat; (** stat(2) for this entry. *) - dent_link : string; (** (for symlinks only) readlink(2). *) -} - (** Directory entry returned by {!read_directory}. *) - -val read_directory : ?fail:exn callback -> source -> string -> direntry list callback -> unit +val read_directory : ?fail:exn callback -> Slave_types.source -> string -> Slave_types.direntry list callback -> unit (** [read_directory src dir cb] reads the contents of the directory [dir] from source [src], and calls the callback function [cb] with the resulting list of directory entries, if successful. @@ -159,30 +150,12 @@ 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 disk_usage : ?fail:exn callback -> source -> string -> int64 callback -> unit - (** [disk_usage src pathname cb] calculates the disk usage of - directory [pathname] and calls the callback with the answer - (size of {b kilobytes}). *) +val run_command : ?fail:exn callback -> string -> unit callback -> unit + (** [run_command cmd] runs an external command [cmd]. This is + useful for possibly long-running commands as it keeps the + display interactive. Be careful to quote arguments in the + command properly (see {!Filename.quote}). The external command + must eventually terminate and must not wait for user input. *) val discard_command_queue : unit -> unit (** [discard_command_queue ()] discards any commands on the command diff --git a/slave_types.ml b/slave_types.ml new file mode 100644 index 0000000..7af8837 --- /dev/null +++ b/slave_types.ml @@ -0,0 +1,62 @@ +(* 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. + *) + +module D = Libvirt.Domain +module G = Guestfs + +type domain = { + dom_id : int; + dom_name : string; + dom_state : D.state; +} + +and inspection_data = { + insp_all_filesystems : (string * string) list; + insp_oses : inspection_os list; +} + +and inspection_os = { + insp_root : string; + insp_arch : string; + insp_distro : string; + insp_filesystems : string array; + insp_hostname : string; + insp_major_version : int; + insp_minor_version : int; + insp_mountpoints : (string * string) list; + insp_package_format : string; + insp_package_management : string; + insp_product_name : string; + insp_type : string; + insp_windows_systemroot : string option; + insp_winreg_DEFAULT : string option; + insp_winreg_SAM : string option; + insp_winreg_SECURITY : string option; + insp_winreg_SOFTWARE : string option; + insp_winreg_SYSTEM : string option; +} + +and source = OS of inspection_os | Volume of string + +and direntry = { + dent_name : string; + dent_stat : G.stat; + dent_link : string; +} + +and download_dir_tarball_format = Tar | TGZ | TXZ diff --git a/slave_types.mli b/slave_types.mli new file mode 100644 index 0000000..e039bb6 --- /dev/null +++ b/slave_types.mli @@ -0,0 +1,69 @@ +(* 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 types used by the slave thread. *) + +type domain = { + dom_id : int; + dom_name : string; + dom_state : Libvirt.Domain.state; +} + (** List of domains as returned in the {!Slave.connect} callback. *) + +type inspection_data = { + insp_all_filesystems : (string * string) list; + (** see {!Guestfs.list_filesystems} *) + insp_oses : inspection_os list; + (** one entry per root (operating system), see {!Guestfs.inspect_os} *) +} + (** The inspection data returned in the callback from + {!Slave.open_domain} and {!Slave.open_images}. *) + +and inspection_os = { + insp_root : string; (** see {!Guestfs.inspect_os} *) + insp_arch : string; + insp_distro : string; + insp_filesystems : string array; + insp_hostname : string; + insp_major_version : int; + insp_minor_version : int; + insp_mountpoints : (string * string) list; + insp_package_format : string; + insp_package_management : string; + insp_product_name : string; + insp_type : string; + insp_windows_systemroot : string option; + insp_winreg_DEFAULT : string option; (* registry files *) + insp_winreg_SAM : string option; + insp_winreg_SECURITY : string option; + insp_winreg_SOFTWARE : string option; + insp_winreg_SYSTEM : string option; +} + +type source = OS of inspection_os | Volume of string + (** Source type used by {!Slave.read_directory}. *) + +type direntry = { + dent_name : string; (** Basename in directory. *) + dent_stat : Guestfs.stat; (** stat(2) for this entry. *) + dent_link : string; (** (for symlinks only) readlink(2). *) +} + (** Directory entry returned by {!Slave.read_directory}. *) + +type download_dir_tarball_format = Tar | TGZ | TXZ + (** Download format, parameter of {!Slave.download_dir_tarball}. *) diff --git a/slave_utils.ml b/slave_utils.ml new file mode 100644 index 0000000..daa7463 --- /dev/null +++ b/slave_utils.ml @@ -0,0 +1,198 @@ +(* 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 CamomileLibrary +open Default.Camomile + +open Utils + +open Slave_types + +open Printf + +module C = Libvirt.Connect +module Cond = Condition +module D = Libvirt.Domain +module G = Guestfs +module M = Mutex +module Q = Queue + +let with_mount_ro g src (f : unit -> 'a) : 'a = + Std.finally (fun () -> g#umount_all ()) ( + fun () -> + (* Do the mount - could be OS or single volume. *) + (match src with + | Volume dev -> g#mount_ro dev "/"; + | OS { insp_mountpoints = mps } -> + (* Sort the mountpoint keys by length, shortest first. *) + let cmp (a,_) (b,_) = compare (String.length a) (String.length b) in + let mps = List.sort ~cmp mps in + (* Mount the filesystems. *) + List.iter (fun (mp, dev) -> g#mount_ro dev mp) mps + ); + f () + ) () + +(* See: + * https://bugzilla.redhat.com/show_bug.cgi?id=663407 + * http://git.annexia.org/?p=libguestfs.git;a=commit;h=3a3836b933b80c4f9f2c767fda4f8b459f998db2 + * http://www.tuxera.com/community/ntfs-3g-advanced/junction-points-and-symbolic-links/ + * http://www.tuxera.com/community/ntfs-3g-advanced/extended-attributes/ + * http://www.codeproject.com/KB/winsdk/junctionpoints.aspx + *) +let get_ntfs_reparse_data g path = + let data = g#lgetxattr path "system.ntfs_reparse_data" in + let link, display = + bitmatch Bitstring.bitstring_of_string data with + (* IO_REPARSE_TAG_MOUNT_POINT *) + | { 0xa0000003_l : 32 : littleendian; + _ : 16 : littleendian; (* data length - ignore it *) + _ : 16 : littleendian; (* reserved *) + link_offset : 16 : littleendian; + link_len : 16 : littleendian; + display_offset : 16 : littleendian; + display_len : 16 : littleendian; + link : link_len * 8 : + string, offset (8 * (link_offset + 0x10)); + display : display_len * 8 : + string, offset (8 * (display_offset + 0x10)) } -> + (* These strings should always be valid UTF16LE, but the caller + * is prepared to catch any exception if this fails. + *) + let link = windows_string_to_utf8 link in + let display = windows_string_to_utf8 display in + link, display + | { 0xa0000003_l : 32 : littleendian } -> + invalid_arg ( + sprintf "%s: could not parse IO_REPARSE_TAG_MOUNT_POINT data" path + ) + + (* IO_REPARSE_TAG_SYMLINK *) + | { 0xa000000c_l : 32 : littleendian; + _ : 16 : littleendian; (* data length - ignore it *) + _ : 16 : littleendian; (* reserved *) + link_offset : 16 : littleendian; + link_len : 16 : littleendian; + display_offset : 16 : littleendian; + display_len : 16 : littleendian; + link : link_len * 8 : + string, offset (8 * (link_offset + 0x14)); + display : display_len * 8 : + string, offset (8 * (display_offset + 0x14)) } -> + let link = windows_string_to_utf8 link in + let display = windows_string_to_utf8 display in + link, display + | { 0xa000000c_l : 32 : littleendian } -> + invalid_arg ( + sprintf "%s: could not parse IO_REPARSE_TAG_SYMLINK data" path + ) + + | { i : 32 : littleendian } -> + invalid_arg ( + sprintf "%s: reparse data of type 0x%lx is not supported" path i + ) + | { _ } -> + invalid_arg (sprintf "%s: reparse data is too short" path) in + + link, display + +(* Given a path which is located somewhere on a mountpoint, return the + * device name. This works by using g#mountpoints and then looking for + * the mount path with the longest match. + *) +let get_mounted_device g path = + let mps = g#mountpoints () in + let mps = List.map ( + fun (dev, mp) -> + if String.starts_with path mp then dev, String.length mp else dev, 0 + ) mps in + let cmp (_,n1) (_,n2) = compare n2 n1 in + let mps = List.sort ~cmp mps in + match mps with + | [] -> + invalid_arg (sprintf "%s: not mounted" path) + | (_,0) :: _ -> + invalid_arg (sprintf "%s: not found on any filesystem" path) + | (dev,_) :: _ -> dev + +let get_filesystem_type g path = + g#vfs_type (get_mounted_device g path) + +(* guestfs_lstatlist has a "hidden" limit of the protocol message size. + * Call this function, but split the list of names into chunks. + *) +let rec lstatlist g dir = function + | [| |] -> [] + | names -> + let len = Array.length names in + let first, rest = + if len <= 1000 then names, [| |] + else ( + Array.sub names 0 1000, + Array.sub names 1000 (len - 1000) + ) in + let stats = g#lstatlist dir first in + Array.to_list stats @ lstatlist g dir rest + +(* For each entry which is a symlink, read the destination of the + * symlink. This is non-trivial because on Windows we cannot use + * readlink but need to instead parse the reparse data from NTFS. + *) +let readlinks g dir names stats = + (* Is the directory on an NTFS filesystem? *) + let vfs_type = get_filesystem_type g dir in + if vfs_type <> "ntfs" then ( + (* Not NTFS, use the fast g#readlinklist method. *) + let rec loop g dir = function + | [| |] -> [] + | names -> + let len = Array.length names in + let first, rest = + if len <= 1000 then names, [| |] + else ( + Array.sub names 0 1000, + Array.sub names 1000 (len - 1000) + ) in + let links = g#readlinklist dir first in + Array.to_list links @ loop g dir rest + in + loop g dir names + ) + else ( + (* NTFS: look up each symlink individually. *) + let r = ref [] in + for i = 0 to Array.length names - 1 do + let name = names.(i) in + let stat = stats.(i) in + let link = + if not (is_symlink stat.G.mode) then "" + else + let path = if dir = "/" then dir ^ name else dir ^ "/" ^ name in + try + let _, display = get_ntfs_reparse_data g path in + display + with exn -> + debug "get_ntfs_reparse_data: %s: failed: %s" + path (Printexc.to_string exn); + "?" in + r := link :: !r + done; + List.rev !r + ) diff --git a/slave_utils.mli b/slave_utils.mli new file mode 100644 index 0000000..6a92b0d --- /dev/null +++ b/slave_utils.mli @@ -0,0 +1,52 @@ +(* 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. + *) + +(** Helpers and utility functions used by the {!Slave} module. *) + +val with_mount_ro : Guestfs.guestfs -> Slave_types.source -> (unit -> 'a) -> 'a + (** [with_mount_ro g source (fun () -> ...)] mounts [source] + read-only and calls the function. It ensures that everything is + unmounted even if an exception is thrown. *) + +val get_ntfs_reparse_data : Guestfs.guestfs -> string -> string * string + (** This parses the NTFS "reparse data" (like a symlink) for the + given path, and returns a pair: the actual path, and the string + to display. + + It can throw many different sorts of exception, so + callers should be prepared for that and able to turn + exceptions into a suitable error message. *) + +val get_mounted_device : Guestfs.guestfs -> string -> string + (** [get_mounted_device g path] returns the device mounted on [path] + (where [path] can be any file or directory within the + device). *) + +val get_filesystem_type : Guestfs.guestfs -> string -> string + (** [get_filesystem_type g path] returns the filesystem type of + the filesystem that contains [path]. *) + +val lstatlist : Guestfs.guestfs -> string -> string array -> Guestfs.stat list + (** This is like {!Guestfs.lstatlist} but it splits the request up + into smaller chunks to avoid exceeding the protocol limit. *) + +val readlinks : Guestfs.guestfs -> string -> string array -> Guestfs.stat array -> string list + (** This is like {!Guestfs.readlinklist} but: (1) It splits the + request up to avoid exceeding the protocol limit; and (2) it + resolves NTFS symbolic links using the NTFS reparse data, not + ntfs-3g. *) diff --git a/utils.ml b/utils.ml index 95c1289..e0c2ff1 100644 --- a/utils.ml +++ b/utils.ml @@ -156,7 +156,7 @@ let tmpdir () = (* Note this is secure, because if the name already exists, even as a * symlink, mkdir(2) will fail. *) - let tmpdir = Filename.temp_dir_name // sprintf "febootstrap%s.tmp" data in + let tmpdir = Filename.temp_dir_name // sprintf "guestfsbrowser%s.tmp" data in Unix.mkdir tmpdir 0o700; at_exit (fun () -> @@ -218,3 +218,7 @@ and reg_hex_of_string ?(split_long_lines=false) v = (int_of_char c) ) vs in String.concat "," vs + +let local_file_exists filename = + try Unix.access filename [Unix.F_OK]; true + with Unix.Unix_error _ -> false diff --git a/utils.mli b/utils.mli index 7a15144..c74a413 100644 --- a/utils.mli +++ b/utils.mli @@ -125,3 +125,6 @@ val windows_string_to_utf8 : string -> string val printable_hivex_value : ?split_long_lines:bool -> Hivex.hive_type -> string -> string (** [printable_hivex_value t v] converts raw registry value [v] of type [t] to a printable string. *) + +val local_file_exists : string -> bool + (** Returns true if the (local) file exists. *) diff --git a/window.ml b/window.ml index aac7380..dd4f5ad 100644 --- a/window.ml +++ b/window.ml @@ -19,6 +19,7 @@ open Printf open Utils +open Slave_types module G = Guestfs @@ -59,7 +60,7 @@ and populate_vmcombo ws doms = let combo, (model, column) = ws.vmcombo in model#clear (); List.iter ( - fun { Slave.dom_name = name } -> + fun { dom_name = name } -> let row = model#append () in model#set ~row ~column name ) doms @@ -96,12 +97,12 @@ and when_opened_disk_images ws images data = and when_opened_common ws name data = (* Dump some of the inspection data in debug messages. *) List.iter (fun (dev, t) -> debug "filesystem: %s: %s" dev t) - data.Slave.insp_all_filesystems; + data.insp_all_filesystems; List.iter ( - fun { Slave.insp_root = root; insp_type = typ; insp_distro = distro; + fun { insp_root = root; insp_type = typ; insp_distro = distro; insp_major_version = major; insp_minor_version = minor } -> debug "root device %s contains %s %s %d.%d" root typ distro major minor; - ) data.Slave.insp_oses; + ) data.insp_oses; Filetree.add ws.view name data @@ -293,7 +294,7 @@ and when_connected_cli_request ws guest doms = | 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 i = loop 0 (List.map (fun { dom_name = name } -> name) doms) in let combo, _ = ws.vmcombo in combo#set_active i