--- /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
+ )
git.annexia.org / guestfs-browser.git / blobdiff