slave_utils.ml

   1 (* Guestfs Browser.
   2  * Copyright (C) 2010 Red Hat Inc.
   3  *
   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.
   8  *
   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.
  13  *
  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.
  17  *)
  18
  19 open ExtList
  20 open ExtString
  21
  22 open Utils
  23
  24 open Slave_types
  25
  26 open Printf
  27
  28 module G = Guestfs
  29
  30 let with_mount_ro g src (f : unit -> 'a) : 'a =
  31   Std.finally (fun () -> g#umount_all ()) (
  32     fun () ->
  33       (* Do the mount - could be OS or single volume. *)
  34       (match src with
  35        | Volume dev -> g#mount_ro dev "/";
  36        | OS { insp_mountpoints = mps } ->
  37            (* Sort the mountpoint keys by length, shortest first. *)
  38            let cmp (a,_) (b,_) = compare (String.length a) (String.length b) in
  39            let mps = List.sort ~cmp mps in
  40            (* Mount the filesystems. *)
  41            List.iter (fun (mp, dev) -> g#mount_ro dev mp) mps
  42       );
  43       f ()
  44   ) ()
  45
  46 (* See:
  47  * https://bugzilla.redhat.com/show_bug.cgi?id=663407
  48  * http://git.annexia.org/?p=libguestfs.git;a=commit;h=3a3836b933b80c4f9f2c767fda4f8b459f998db2
  49  * http://www.tuxera.com/community/ntfs-3g-advanced/junction-points-and-symbolic-links/
  50  * http://www.tuxera.com/community/ntfs-3g-advanced/extended-attributes/
  51  * http://www.codeproject.com/KB/winsdk/junctionpoints.aspx
  52  *)
  53 let get_ntfs_reparse_data g path =
  54   let data = g#lgetxattr path "system.ntfs_reparse_data" in
  55   let link, display =
  56     bitmatch Bitstring.bitstring_of_string data with
  57     (* IO_REPARSE_TAG_MOUNT_POINT *)
  58     | { 0xa0000003_l : 32 : littleendian;
  59         _ : 16 : littleendian; (* data length - ignore it *)
  60         _ : 16 : littleendian; (* reserved *)
  61         link_offset : 16 : littleendian;
  62         link_len : 16 : littleendian;
  63         display_offset : 16 : littleendian;
  64         display_len : 16 : littleendian;
  65         link : link_len * 8 :
  66           string, offset (8 * (link_offset + 0x10));
  67         display : display_len * 8 :
  68           string, offset (8 * (display_offset + 0x10)) } ->
  69           (* These strings should always be valid UTF16LE, but the caller
  70            * is prepared to catch any exception if this fails.
  71            *)
  72           let link = windows_string_to_utf8 link in
  73           let display = windows_string_to_utf8 display in
  74           link, display
  75     | { 0xa0000003_l : 32 : littleendian } ->
  76           invalid_arg (
  77             sprintf "%s: could not parse IO_REPARSE_TAG_MOUNT_POINT data" path
  78           )
  79
  80     (* IO_REPARSE_TAG_SYMLINK *)
  81     | { 0xa000000c_l : 32 : littleendian;
  82         _ : 16 : littleendian; (* data length - ignore it *)
  83         _ : 16 : littleendian; (* reserved *)
  84         link_offset : 16 : littleendian;
  85         link_len : 16 : littleendian;
  86         display_offset : 16 : littleendian;
  87         display_len : 16 : littleendian;
  88         link : link_len * 8 :
  89           string, offset (8 * (link_offset + 0x14));
  90         display : display_len * 8 :
  91           string, offset (8 * (display_offset + 0x14)) } ->
  92           let link = windows_string_to_utf8 link in
  93           let display = windows_string_to_utf8 display in
  94           link, display
  95     | { 0xa000000c_l : 32 : littleendian } ->
  96           invalid_arg (
  97             sprintf "%s: could not parse IO_REPARSE_TAG_SYMLINK data" path
  98           )
  99
 100     | { i : 32 : littleendian } ->
 101           invalid_arg (
 102             sprintf "%s: reparse data of type 0x%lx is not supported" path i
 103           )
 104     | { _ } ->
 105           invalid_arg (sprintf "%s: reparse data is too short" path) in
 106
 107   link, display
 108
 109 (* Given a path which is located somewhere on a mountpoint, return the
 110  * device name.  This works by using g#mountpoints and then looking for
 111  * the mount path with the longest match.
 112  *)
 113 let get_mounted_device g path =
 114   let mps = g#mountpoints () in
 115   let mps = List.map (
 116     fun (dev, mp) ->
 117       if String.starts_with path mp then dev, String.length mp else dev, 0
 118   ) mps in
 119   let cmp (_,n1) (_,n2) = compare n2 n1 in
 120   let mps = List.sort ~cmp mps in
 121   match mps with
 122   | [] ->
 123       invalid_arg (sprintf "%s: not mounted" path)
 124   | (_,0) :: _ ->
 125       invalid_arg (sprintf "%s: not found on any filesystem" path)
 126   | (dev,_) :: _ -> dev
 127
 128 let get_filesystem_type g path =
 129   g#vfs_type (get_mounted_device g path)
 130
 131 (* guestfs_lstatlist has a "hidden" limit of the protocol message size.
 132  * Call this function, but split the list of names into chunks.
 133  *)
 134 let rec lstatlist g dir = function
 135   | [| |] -> []
 136   | names ->
 137       let len = Array.length names in
 138       let first, rest =
 139         if len <= 1000 then names, [| |]
 140         else (
 141           Array.sub names 0 1000,
 142           Array.sub names 1000 (len - 1000)
 143         ) in
 144       let stats = g#lstatlist dir first in
 145       Array.to_list stats @ lstatlist g dir rest
 146
 147 (* For each entry which is a symlink, read the destination of the
 148  * symlink.  This is non-trivial because on Windows we cannot use
 149  * readlink but need to instead parse the reparse data from NTFS.
 150  *)
 151 let readlinks g dir names stats =
 152   (* Is the directory on an NTFS filesystem? *)
 153   let vfs_type = get_filesystem_type g dir in
 154   if vfs_type <> "ntfs" then (
 155     (* Not NTFS, use the fast g#readlinklist method. *)
 156     let rec loop g dir = function
 157       | [| |] -> []
 158       | names ->
 159           let len = Array.length names in
 160           let first, rest =
 161             if len <= 1000 then names, [| |]
 162             else (
 163               Array.sub names 0 1000,
 164               Array.sub names 1000 (len - 1000)
 165             ) in
 166           let links = g#readlinklist dir first in
 167           Array.to_list links @ loop g dir rest
 168     in
 169     loop g dir names
 170   )
 171   else (
 172     (* NTFS: look up each symlink individually. *)
 173     let r = ref [] in
 174     for i = 0 to Array.length names - 1 do
 175       let name = names.(i) in
 176       let stat = stats.(i) in
 177       let link =
 178         if not (is_symlink stat.G.mode) then ""
 179         else
 180           let path = if dir = "/" then dir ^ name else dir ^ "/" ^ name in
 181           try
 182             let _, display = get_ntfs_reparse_data g path in
 183             display
 184           with exn ->
 185             debug "get_ntfs_reparse_data: %s: failed: %s"
 186               path (Printexc.to_string exn);
 187             "?" in
 188       r := link :: !r
 189     done;
 190     List.rev !r
 191   )