2 * Copyright (C) 2010 Red Hat Inc.
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 2 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License along
15 * with this program; if not, write to the Free Software Foundation, Inc.,
16 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
30 module C = Libvirt.Connect
31 module Cond = Condition
32 module D = Libvirt.Domain
37 let with_mount_ro g src (f : unit -> 'a) : 'a =
38 Std.finally (fun () -> g#umount_all ()) (
40 (* Do the mount - could be OS or single volume. *)
42 | Volume dev -> g#mount_ro dev "/";
43 | OS { insp_mountpoints = mps } ->
44 (* Sort the mountpoint keys by length, shortest first. *)
45 let cmp (a,_) (b,_) = compare (String.length a) (String.length b) in
46 let mps = List.sort ~cmp mps in
47 (* Mount the filesystems. *)
48 List.iter (fun (mp, dev) -> g#mount_ro dev mp) mps
54 * https://bugzilla.redhat.com/show_bug.cgi?id=663407
55 * http://git.annexia.org/?p=libguestfs.git;a=commit;h=3a3836b933b80c4f9f2c767fda4f8b459f998db2
56 * http://www.tuxera.com/community/ntfs-3g-advanced/junction-points-and-symbolic-links/
57 * http://www.tuxera.com/community/ntfs-3g-advanced/extended-attributes/
58 * http://www.codeproject.com/KB/winsdk/junctionpoints.aspx
60 let get_ntfs_reparse_data g path =
61 let data = g#lgetxattr path "system.ntfs_reparse_data" in
63 bitmatch Bitstring.bitstring_of_string data with
64 (* IO_REPARSE_TAG_MOUNT_POINT *)
65 | { 0xa0000003_l : 32 : littleendian;
66 _ : 16 : littleendian; (* data length - ignore it *)
67 _ : 16 : littleendian; (* reserved *)
68 link_offset : 16 : littleendian;
69 link_len : 16 : littleendian;
70 display_offset : 16 : littleendian;
71 display_len : 16 : littleendian;
73 string, offset (8 * (link_offset + 0x10));
74 display : display_len * 8 :
75 string, offset (8 * (display_offset + 0x10)) } ->
76 (* These strings should always be valid UTF16LE, but the caller
77 * is prepared to catch any exception if this fails.
79 let link = windows_string_to_utf8 link in
80 let display = windows_string_to_utf8 display in
82 | { 0xa0000003_l : 32 : littleendian } ->
84 sprintf "%s: could not parse IO_REPARSE_TAG_MOUNT_POINT data" path
87 (* IO_REPARSE_TAG_SYMLINK *)
88 | { 0xa000000c_l : 32 : littleendian;
89 _ : 16 : littleendian; (* data length - ignore it *)
90 _ : 16 : littleendian; (* reserved *)
91 link_offset : 16 : littleendian;
92 link_len : 16 : littleendian;
93 display_offset : 16 : littleendian;
94 display_len : 16 : littleendian;
96 string, offset (8 * (link_offset + 0x14));
97 display : display_len * 8 :
98 string, offset (8 * (display_offset + 0x14)) } ->
99 let link = windows_string_to_utf8 link in
100 let display = windows_string_to_utf8 display in
102 | { 0xa000000c_l : 32 : littleendian } ->
104 sprintf "%s: could not parse IO_REPARSE_TAG_SYMLINK data" path
107 | { i : 32 : littleendian } ->
109 sprintf "%s: reparse data of type 0x%lx is not supported" path i
112 invalid_arg (sprintf "%s: reparse data is too short" path) in
116 (* Given a path which is located somewhere on a mountpoint, return the
117 * device name. This works by using g#mountpoints and then looking for
118 * the mount path with the longest match.
120 let get_mounted_device g path =
121 let mps = g#mountpoints () in
124 if String.starts_with path mp then dev, String.length mp else dev, 0
126 let cmp (_,n1) (_,n2) = compare n2 n1 in
127 let mps = List.sort ~cmp mps in
130 invalid_arg (sprintf "%s: not mounted" path)
132 invalid_arg (sprintf "%s: not found on any filesystem" path)
133 | (dev,_) :: _ -> dev
135 let get_filesystem_type g path =
136 g#vfs_type (get_mounted_device g path)
138 (* guestfs_lstatlist has a "hidden" limit of the protocol message size.
139 * Call this function, but split the list of names into chunks.
141 let rec lstatlist g dir = function
144 let len = Array.length names in
146 if len <= 1000 then names, [| |]
148 Array.sub names 0 1000,
149 Array.sub names 1000 (len - 1000)
151 let stats = g#lstatlist dir first in
152 Array.to_list stats @ lstatlist g dir rest
154 (* For each entry which is a symlink, read the destination of the
155 * symlink. This is non-trivial because on Windows we cannot use
156 * readlink but need to instead parse the reparse data from NTFS.
158 let readlinks g dir names stats =
159 (* Is the directory on an NTFS filesystem? *)
160 let vfs_type = get_filesystem_type g dir in
161 if vfs_type <> "ntfs" then (
162 (* Not NTFS, use the fast g#readlinklist method. *)
163 let rec loop g dir = function
166 let len = Array.length names in
168 if len <= 1000 then names, [| |]
170 Array.sub names 0 1000,
171 Array.sub names 1000 (len - 1000)
173 let links = g#readlinklist dir first in
174 Array.to_list links @ loop g dir rest
179 (* NTFS: look up each symlink individually. *)
181 for i = 0 to Array.length names - 1 do
182 let name = names.(i) in
183 let stat = stats.(i) in
185 if not (is_symlink stat.G.mode) then ""
187 let path = if dir = "/" then dir ^ name else dir ^ "/" ^ name in
189 let _, display = get_ntfs_reparse_data g path in
192 debug "get_ntfs_reparse_data: %s: failed: %s"
193 path (Printexc.to_string exn);