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 open CamomileLibrary
  22 open Default.Camomile
  23
  24 open Utils
  25
  26 open Slave_types
  27
  28 open Printf
  29
  30 module C = Libvirt.Connect
  31 module Cond = Condition
  32 module D = Libvirt.Domain
  33 module G = Guestfs
  34 module M = Mutex
  35 module Q = Queue
  36
  37 let with_mount_ro g src (f : unit -> 'a) : 'a =
  38   Std.finally (fun () -> g#umount_all ()) (
  39     fun () ->
  40       (* Do the mount - could be OS or single volume. *)
  41       (match src with
  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
  49       );
  50       f ()
  51   ) ()
  52
  53 (* See:
  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
  59  *)
  60 let get_ntfs_reparse_data g path =
  61   let data = g#lgetxattr path "system.ntfs_reparse_data" in
  62   let link, display =
  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;
  72         link : link_len * 8 :
  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.
  78            *)
  79           let link = windows_string_to_utf8 link in
  80           let display = windows_string_to_utf8 display in
  81           link, display
  82     | { 0xa0000003_l : 32 : littleendian } ->
  83           invalid_arg (
  84             sprintf "%s: could not parse IO_REPARSE_TAG_MOUNT_POINT data" path
  85           )
  86
  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;
  95         link : link_len * 8 :
  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
 101           link, display
 102     | { 0xa000000c_l : 32 : littleendian } ->
 103           invalid_arg (
 104             sprintf "%s: could not parse IO_REPARSE_TAG_SYMLINK data" path
 105           )
 106
 107     | { i : 32 : littleendian } ->
 108           invalid_arg (
 109             sprintf "%s: reparse data of type 0x%lx is not supported" path i
 110           )
 111     | { _ } ->
 112           invalid_arg (sprintf "%s: reparse data is too short" path) in
 113
 114   link, display
 115
 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.
 119  *)
 120 let get_mounted_device g path =
 121   let mps = g#mountpoints () in
 122   let mps = List.map (
 123     fun (dev, mp) ->
 124       if String.starts_with path mp then dev, String.length mp else dev, 0
 125   ) mps in
 126   let cmp (_,n1) (_,n2) = compare n2 n1 in
 127   let mps = List.sort ~cmp mps in
 128   match mps with
 129   | [] ->
 130       invalid_arg (sprintf "%s: not mounted" path)
 131   | (_,0) :: _ ->
 132       invalid_arg (sprintf "%s: not found on any filesystem" path)
 133   | (dev,_) :: _ -> dev
 134
 135 let get_filesystem_type g path =
 136   g#vfs_type (get_mounted_device g path)
 137
 138 (* guestfs_lstatlist has a "hidden" limit of the protocol message size.
 139  * Call this function, but split the list of names into chunks.
 140  *)
 141 let rec lstatlist g dir = function
 142   | [| |] -> []
 143   | names ->
 144       let len = Array.length names in
 145       let first, rest =
 146         if len <= 1000 then names, [| |]
 147         else (
 148           Array.sub names 0 1000,
 149           Array.sub names 1000 (len - 1000)
 150         ) in
 151       let stats = g#lstatlist dir first in
 152       Array.to_list stats @ lstatlist g dir rest
 153
 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.
 157  *)
 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
 164       | [| |] -> []
 165       | names ->
 166           let len = Array.length names in
 167           let first, rest =
 168             if len <= 1000 then names, [| |]
 169             else (
 170               Array.sub names 0 1000,
 171               Array.sub names 1000 (len - 1000)
 172             ) in
 173           let links = g#readlinklist dir first in
 174           Array.to_list links @ loop g dir rest
 175     in
 176     loop g dir names
 177   )
 178   else (
 179     (* NTFS: look up each symlink individually. *)
 180     let r = ref [] in
 181     for i = 0 to Array.length names - 1 do
 182       let name = names.(i) in
 183       let stat = stats.(i) in
 184       let link =
 185         if not (is_symlink stat.G.mode) then ""
 186         else
 187           let path = if dir = "/" then dir ^ name else dir ^ "/" ^ name in
 188           try
 189             let _, display = get_ntfs_reparse_data g path in
 190             display
 191           with exn ->
 192             debug "get_ntfs_reparse_data: %s: failed: %s"
 193               path (Printexc.to_string exn);
 194             "?" in
 195       r := link :: !r
 196     done;
 197     List.rev !r
 198   )