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