X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;ds=sidebyside;f=slave.ml;h=01105ef8700c143eadb89f83c684a3ccadb0f8f4;hb=f09bb82de01019f24411cac2916d9567b5e9a235;hp=e27ced74eab6cc64378d9c6fbdaa697f45b46fb3;hpb=e0047b09f88dcfa6dd9e771caf57a744095321f2;p=guestfs-browser.git diff --git a/slave.ml b/slave.ml index e27ced7..01105ef 100644 --- a/slave.ml +++ b/slave.ml @@ -17,12 +17,18 @@ *) open ExtList -open Printf +open ExtString +open CamomileLibrary +open Default.Camomile + open Utils +open Printf + module C = Libvirt.Connect module Cond = Condition module D = Libvirt.Domain +module G = Guestfs module M = Mutex module Q = Queue @@ -76,7 +82,7 @@ and source = OS of inspection_os | Volume of string and direntry = { dent_name : string; - dent_stat : Guestfs.stat; + dent_stat : G.stat; dent_link : string; } @@ -286,7 +292,7 @@ and execute_command = function dom_name = D.get_name d; dom_state = (D.get_info d).D.state } ) doms in - let cmp { dom_name = n1 } { dom_name = n2 } = compare n1 n2 in + let cmp { dom_name = n1 } { dom_name = n2 } = UTF8.compare n1 n2 in let doms = List.sort ~cmp doms in status "Connected to %s" printable_name; @@ -370,7 +376,7 @@ and execute_command = function let names = g#ls dir in (* sorted and without . and .. *) let names = Array.to_list names in let stats = lstatlist_wrapper g dir names in - let links = readlinklist_wrapper g dir names in + let links = readlink_wrapper g dir names stats in names, stats, links ) in assert ( @@ -472,7 +478,7 @@ and open_disk_images images cb = debug "opening disk image %s" (string_of_images images); close_g (); - let g' = new Guestfs.guestfs () in + let g' = new G.guestfs () in g := Some g'; let g = g' in @@ -515,7 +521,7 @@ and open_disk_images images cb = let roots = try Array.to_list (g#inspect_os ()) with - Guestfs.Error msg -> + G.Error msg -> debug "inspection failed (error ignored): %s" msg; [] in @@ -526,7 +532,7 @@ and open_disk_images images cb = if typ <> "windows" then None else ( try Some (g#inspect_get_windows_systemroot root) - with Guestfs.Error _ -> None + with G.Error _ -> None ) in (* Create most of the OS object that we're going to return. We @@ -566,7 +572,7 @@ and open_disk_images images cb = let path = sprintf "%s/system32/config/%s" sysroot filename in try Some (g#case_sensitive_path path) - with Guestfs.Error _ -> None + with G.Error _ -> None in check_for_hive "default", check_for_hive "sam", @@ -605,14 +611,123 @@ and lstatlist_wrapper g dir = function let xs = Array.to_list xs in xs @ lstatlist_wrapper g dir names -(* Same as above for guestfs_readlinklist. *) -and readlinklist_wrapper g dir = function - | [] -> [] - | names -> - let names', names = List.take 1000 names, List.drop 1000 names in - let xs = g#readlinklist dir (Array.of_list names') in - let xs = Array.to_list xs in - xs @ readlinklist_wrapper g dir names +(* 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. + *) +and readlink_wrapper g dir names stats = + (* Is the directory on an NTFS filesystem? *) + let dev = get_mounted_device g dir in + if g#vfs_type dev <> "ntfs" then ( + (* Not NTFS, use the fast g#readlinklist method. *) + let rec readlinklist_wrapper g dir = function + | [] -> [] + | names -> + let names', names = List.take 1000 names, List.drop 1000 names in + let xs = g#readlinklist dir (Array.of_list names') in + let xs = Array.to_list xs in + xs @ readlinklist_wrapper g dir names + in + readlinklist_wrapper g dir names + ) + else ( + (* NTFS: look up each symlink individually. *) + List.map ( + fun (name, stat) -> + 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); + "?" + ) (List.combine names stats) + ) + +(* 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 + *) +and 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. + *) +and 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 (* Start up one slave thread. *) let slave_thread = Thread.create loop ()