From 3ab788383673a8300925a7de6113ef3962378a15 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 17 Dec 2010 12:24:01 +0000 Subject: [PATCH] Use bitstring, enable display of symlinks on NTFS. --- Makefile.am | 8 +-- configure.ac | 7 ++- filetree_markup.ml | 45 +++++---------- guestfs-browser.spec.in | 8 +-- slave.ml | 145 +++++++++++++++++++++++++++++++++++++++++++----- utils.ml | 56 +++++-------------- utils.mli | 20 ++----- window.ml | 4 +- 8 files changed, 182 insertions(+), 111 deletions(-) diff --git a/Makefile.am b/Makefile.am index 8a1a8d9..7bae6e6 100644 --- a/Makefile.am +++ b/Makefile.am @@ -71,16 +71,16 @@ OBJECTS = \ bin_SCRIPTS = guestfs-browser OCAMLPACKAGES = \ - libvirt,guestfs,hivex,lablgtk2,extlib,xml-light,camomile,threads + -package libvirt,guestfs,hivex,lablgtk2,extlib,xml-light,camomile,threads,bitstring,bitstring.syntax -syntax bitstring OCAMLCFLAGS = \ -g \ -warn-error CDEFLMPSUVYZX \ -thread \ - -package $(OCAMLPACKAGES) \ + $(OCAMLPACKAGES) \ -predicates threads OCAMLOPTFLAGS = $(OCAMLCFLAGS) OCAMLDOCFLAGS = \ - -package $(OCAMLPACKAGES) \ + $(OCAMLPACKAGES) \ -predicates threads \ -I +threads \ -sort -html @@ -155,7 +155,7 @@ depend: .depend .depend: $(wildcard *.mli) $(wildcard *.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep $^ | \ + $(OCAMLFIND) ocamldep $(OCAMLPACKAGES) $^ | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ sort > $@-t mv $@-t $@ diff --git a/configure.ac b/configure.ac index d1853ab..05a7dcf 100644 --- a/configure.ac +++ b/configure.ac @@ -70,7 +70,12 @@ fi AC_CHECK_OCAML_PKG([camomile]) if test "$OCAML_PKG_camomile" = "no"; then - AC_MSG_ERROR([Please install OCaml module 'camomile'.]) + AC_MSG_ERROR([Please install OCaml module 'camomile' (including the data module if that is separate).]) +fi + +AC_CHECK_OCAML_PKG([bitstring]) +if test "$OCAML_PKG_bitstring" = "no"; then + AC_MSG_ERROR([Please install OCaml module 'bitstring'.]) fi AC_CHECK_OCAML_PKG([extlib]) diff --git a/filetree_markup.ml b/filetree_markup.ml index 206700b..55bb425 100644 --- a/filetree_markup.ml +++ b/filetree_markup.ml @@ -18,10 +18,9 @@ open ExtString open ExtList -open Unix - open CamomileLibrary open Default.Camomile +open Unix open Utils open Filetree_type @@ -109,15 +108,13 @@ and markup_of_regvalue ?(visited = false) h value = | Hivex.REG_EXPAND_SZ -> markup_windows_string v | Hivex.REG_BINARY -> markup_hex_data v | Hivex.REG_DWORD -> - if len = 4 then - sprintf "%08lx" (i32_of_string_le v) - else - markup_hex_data v + (bitmatch Bitstring.bitstring_of_string v with + | { i : 32 : littleendian } -> sprintf "%08lx" i + | { _ } -> markup_hex_data v) | Hivex.REG_DWORD_BIG_ENDIAN -> - if len = 4 then - sprintf "%08lx" (i32_of_string_be v) - else - markup_hex_data v + (bitmatch Bitstring.bitstring_of_string v with + | { i : 32 : bigendian } -> sprintf "%08lx" i + | { _ } -> markup_hex_data v) | Hivex.REG_LINK -> markup_hex_data v | Hivex.REG_MULTI_SZ -> (* XXX could do better with this *) markup_hex_data v @@ -125,10 +122,9 @@ and markup_of_regvalue ?(visited = false) h value = | Hivex.REG_FULL_RESOURCE_DESCRIPTOR -> markup_hex_data v | Hivex.REG_RESOURCE_REQUIREMENTS_LIST -> markup_hex_data v | Hivex.REG_QWORD -> - if len = 8 then - sprintf "%016Lx" (i64_of_string_le v) - else - markup_hex_data v + (bitmatch Bitstring.bitstring_of_string v with + | { i : 64 : littleendian } -> sprintf "%016Lx" i + | { _ } -> markup_hex_data v) | Hivex.REG_UNKNOWN i32 -> markup_hex_data v ) in @@ -147,23 +143,10 @@ and markup_hex_data v = (* Best guess the format of the string and convert to UTF-8. *) and markup_windows_string v = - let utf16le = CharEncoding.utf16le in - let utf8 = CharEncoding.utf8 in - try - let v = CharEncoding.recode_string ~in_enc:utf16le ~out_enc:utf8 v in - (* Registry strings include the final \0 so remove this if present. *) - let len = UTF8.length v in - let v = - if len > 0 && UChar.code (UTF8.get v (len-1)) = 0 then - String.sub v 0 (UTF8.last v) - else - v in - markup_escape v - with - | CharEncoding.Malformed_code - | CharEncoding.Out_of_range -> - (* Fallback to displaying the string as hex. *) - markup_hex_data v + try markup_escape (windows_string_to_utf8 v) + with CharEncoding.Malformed_code | CharEncoding.Out_of_range -> + (* Fallback to displaying the string as hex. *) + markup_hex_data v and normal (r, g, b) = let r = if r < 0 then 0 else if r > 255 then 255 else r in diff --git a/guestfs-browser.spec.in b/guestfs-browser.spec.in index cb745e3..889ea95 100644 --- a/guestfs-browser.spec.in +++ b/guestfs-browser.spec.in @@ -12,11 +12,11 @@ Source0: http://people.redhat.com/~rjones/guestfs-browser/files/guestfs-b BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n) BuildRequires: hivex-devel >= 1.2.4-3 -BuildRequires: libguestfs-devel >= 1.7.9 +BuildRequires: libguestfs-devel >= 1.7.24 BuildRequires: libvirt-devel BuildRequires: ocaml -BuildRequires: ocaml-camomile-devel -BuildRequires: ocaml-camomile-data +BuildRequires: ocaml-bitstring-devel +BuildRequires: ocaml-camomile-devel, ocaml-camomile-data BuildRequires: ocaml-extlib-devel BuildRequires: ocaml-findlib-devel BuildRequires: ocaml-hivex-devel @@ -27,7 +27,7 @@ BuildRequires: ocaml-xml-light-devel BuildRequires: /usr/bin/pod2man BuildRequires: /usr/bin/pod2html -Requires: libguestfs >= 1.7.9 +Requires: libguestfs >= 1.7.24 # Only needed to build the internal documentation. #BuildRequires: ocaml-ocamldoc diff --git a/slave.ml b/slave.ml index e27ced7..8cf8199 100644 --- a/slave.ml +++ b/slave.ml @@ -17,12 +17,18 @@ *) open ExtList -open Printf +open ExtString +open CamomileLibrary +open Default.Camomile + open Utils +open Printf + module C = Libvirt.Connect module Cond = Condition module D = Libvirt.Domain +module G = Guestfs module M = Mutex module Q = Queue @@ -76,7 +82,7 @@ and source = OS of inspection_os | Volume of string and direntry = { dent_name : string; - dent_stat : Guestfs.stat; + dent_stat : G.stat; dent_link : string; } @@ -370,7 +376,7 @@ and execute_command = function 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 = readlinklist_wrapper g dir names in + let links = readlink_wrapper g dir names stats in names, stats, links ) in assert ( @@ -472,7 +478,7 @@ and open_disk_images images cb = debug "opening disk image %s" (string_of_images images); close_g (); - let g' = new Guestfs.guestfs () in + let g' = new G.guestfs () in g := Some g'; let g = g' in @@ -515,7 +521,7 @@ and open_disk_images images cb = let roots = try Array.to_list (g#inspect_os ()) with - Guestfs.Error msg -> + G.Error msg -> debug "inspection failed (error ignored): %s" msg; [] in @@ -526,7 +532,7 @@ and open_disk_images images cb = if typ <> "windows" then None else ( try Some (g#inspect_get_windows_systemroot root) - with Guestfs.Error _ -> None + with G.Error _ -> None ) in (* Create most of the OS object that we're going to return. We @@ -566,7 +572,7 @@ and open_disk_images images cb = let path = sprintf "%s/system32/config/%s" sysroot filename in try Some (g#case_sensitive_path path) - with Guestfs.Error _ -> None + with G.Error _ -> None in check_for_hive "default", check_for_hive "sam", @@ -605,14 +611,123 @@ and lstatlist_wrapper g dir = function let xs = Array.to_list xs in xs @ lstatlist_wrapper g dir names -(* Same as above for guestfs_readlinklist. *) -and readlinklist_wrapper g dir = function - | [] -> [] - | names -> - let names', names = List.take 1000 names, List.drop 1000 names in - let xs = g#readlinklist dir (Array.of_list names') in - let xs = Array.to_list xs in - xs @ readlinklist_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/utils.ml b/utils.ml index ca2432f..f9cf35d 100644 --- a/utils.ml +++ b/utils.ml @@ -17,6 +17,8 @@ *) open ExtString +open CamomileLibrary +open Default.Camomile open Printf @@ -161,44 +163,16 @@ let tmpdir () = ignore (Sys.command cmd)); tmpdir -(* This would be so much simpler with ChriS's delimited - * overloading macro XXX - *) -let i32_of_string_le v = - let b0 = int_of_char (String.unsafe_get v 0) in - let b1 = int_of_char (String.unsafe_get v 1) in - let b2 = int_of_char (String.unsafe_get v 2) in - let b3 = Int32.of_int (int_of_char (String.unsafe_get v 3)) in - Int32.logor - (Int32.of_int (b0 lor (b1 lsl 8) lor (b2 lsl 16))) - (Int32.shift_left b3 24) - -let i32_of_string_be v = - let b0 = Int32.of_int (int_of_char (String.unsafe_get v 0)) in - let b1 = int_of_char (String.unsafe_get v 1) in - let b2 = int_of_char (String.unsafe_get v 2) in - let b3 = int_of_char (String.unsafe_get v 3) in - Int32.logor - (Int32.of_int (b3 lor (b2 lsl 8) lor (b1 lsl 16))) - (Int32.shift_left b0 24) - -let i64_of_string_le v = - let b0 = int_of_char (String.unsafe_get v 0) in - let b1 = int_of_char (String.unsafe_get v 1) in - let b2 = int_of_char (String.unsafe_get v 2) in - let b3 = Int64.of_int (int_of_char (String.unsafe_get v 3)) in - let b4 = Int64.of_int (int_of_char (String.unsafe_get v 4)) in - let b5 = Int64.of_int (int_of_char (String.unsafe_get v 5)) in - let b6 = Int64.of_int (int_of_char (String.unsafe_get v 6)) in - let b7 = Int64.of_int (int_of_char (String.unsafe_get v 7)) in - Int64.logor - (Int64.logor - (Int64.logor - (Int64.logor - (Int64.logor - (Int64.of_int (b0 lor (b1 lsl 8) lor (b2 lsl 16))) - (Int64.shift_left b3 24)) - (Int64.shift_left b4 32)) - (Int64.shift_left b5 40)) - (Int64.shift_left b6 48)) - (Int64.shift_left b7 56) +let utf16le = CharEncoding.utf16le +let utf8 = CharEncoding.utf8 +let recode = CharEncoding.recode_string ~in_enc:utf16le ~out_enc:utf8 + +let windows_string_to_utf8 str = + let str = recode str in + + (* Windows strings include the final \0 so remove this if present. *) + let len = UTF8.length str in + if len > 0 && UChar.code (UTF8.get str (len-1)) = 0 then + String.sub str 0 (UTF8.last str) + else + str diff --git a/utils.mli b/utils.mli index ad14dd0..92e2bb6 100644 --- a/utils.mli +++ b/utils.mli @@ -115,17 +115,9 @@ val tmpdir : unit -> string Note that a fresh temporary directory is returned each time you call this function. *) -val i32_of_string_le : string -> int32 - (** [i32_of_string_le str] treats the 4 character string [str] as - a little endian 32 bit int. NB. The string {b must} be - 4 characters or longer. *) - -val i32_of_string_be : string -> int32 - (** [i32_of_string_le str] treats the 4 character string [str] as - a big endian 32 bit int. NB. The string {b must} be - 4 characters or longer. *) - -val i64_of_string_le : string -> int64 - (** [i64_of_string_le str] treats the 8 character string [str] as - a little endian 64 bit int. NB. The string {b must} be - 8 characters or longer. *) +val windows_string_to_utf8 : string -> string + (** Convert a UTF16LE string to UTF8. This also removes the final + \0 word if there is one. + + This may fail in multiple ways, raising a Camomile exception + which you probably need to catch. *) diff --git a/window.ml b/window.ml index aa32625..aac7380 100644 --- a/window.ml +++ b/window.ml @@ -261,7 +261,9 @@ and make_toolbar ~packing () = let static = Throbber.static () in (*let animation = Throbber.animation () in*) let throbber = - GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in + (* Workaround for http://caml.inria.fr/mantis/view.php?id=4732 *) + let from = Obj.magic 3448763 (* `END *) in + GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from) () in vmcombo, refresh_button, throbber, static -- 1.8.3.1