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
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
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 = \
main.ml \
slave.mli \
slave.ml \
+ slave_types.mli \
+ slave_types.ml \
+ slave_utils.mli \
+ slave_utils.ml \
throbber.ml \
utils.mli \
utils.ml \
utils.cmx \
cmdline.cmx \
deviceSet.cmx \
+ slave_types.cmx \
+ slave_utils.cmx \
slave.cmx \
filetree_type.cmx \
filetree_markup.cmx \
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
(** 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. *)
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])
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"])
open Utils
open DeviceSet
+open Slave_types
open Filetree_type
open Filetree_markup
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 ()
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));
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));
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
| [] -> 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 *)
* 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;
*)
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
and add_top_level_os ({ model = model } as t) name os =
let markup =
sprintf "<b>%s</b>\n<small>%s</small>\n<small>%s</small>"
- (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. *)
(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. *)
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. *)
(* 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. *)
(* 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 _) } ->
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
(* 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
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 =
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.
open Unix
open Utils
+open Slave_types
open Filetree_type
open Printf
* 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 "<span weight=\"bold\" fgcolor=\"%s\">%s</span>"
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 "<span style=\"italic\" fgcolor=\"%s\">%s</span> %s <span style=\"italic\" fgcolor=\"%s\">%s</span>"
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 ->
(**/**)
-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
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.
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
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);
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
(* 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.
*)
(* XXX UGHLEE *)
let data =
sprintf "Type: <b>%s</b>\nDistro: <b>%s</b>\nVersion: <b>%d.%d</b>\nArch.: <b>%s</b>\nPackaging: <b>%s</b>/<b>%s</b>\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%%: <b>%s</b>\n" (markup_escape path))
+ sprintf "Systemroot: <b>%s</b>\n" (markup_escape path))
(String.concat "\n"
(List.map (
fun (mp, dev) ->
sprintf "<b>%s</b> on <b>%s</b>"
(markup_escape dev) (markup_escape mp))
- os.Slave.insp_mountpoints)
+ os.insp_mountpoints)
) in
model#set ~row ~column:t.name_col data
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 "<i>Calculating %s ...</i>" 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 "<i>Calculating file information ...</i>";
+
+ 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 *)
(**/**)
+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
open Utils
+open Slave_types
+
(* See struct/field description in .mli file. *)
type t = {
view : GTree.view;
| 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
* \_ 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
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
| { 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
| 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) *)
[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. *)
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
open Utils
+open Slave_types
+open Slave_utils
+
open Printf
module C = Libvirt.Connect
(* 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, _) ->
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 =
"[" ^
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))
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 -----*)
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
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
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;
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
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
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 ()
(** 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
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
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.
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.
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
--- /dev/null
+(* 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
--- /dev/null
+(* 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}. *)
--- /dev/null
+(* 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
+ )
--- /dev/null
+(* 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. *)
(* 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 () ->
(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
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. *)
open Printf
open Utils
+open Slave_types
module G = Guestfs
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
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
| 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
git.annexia.org / guestfs-browser.git / commitdiff