(* 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 Utils open Slave_types open Printf module G = Guestfs 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 )