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
.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 $@
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])
open ExtString
open ExtList
-open Unix
-
open CamomileLibrary
open Default.Camomile
+open Unix
open Utils
open Filetree_type
| 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
| 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
(* 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
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
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
*)
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
and direntry = {
dent_name : string;
- dent_stat : Guestfs.stat;
+ dent_stat : G.stat;
dent_link : string;
}
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 (
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
let roots =
try Array.to_list (g#inspect_os ())
with
- Guestfs.Error msg ->
+ G.Error msg ->
debug "inspection failed (error ignored): %s" msg;
[] in
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
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",
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 ()
*)
open ExtString
+open CamomileLibrary
+open Default.Camomile
open Printf
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
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. *)
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
git.annexia.org / guestfs-browser.git / commitdiff