slave.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 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 type 'a callback = 'a -> unit
  36
  37 (* The commands. *)
  38 type command =
  39   | Exit_thread
  40   | Connect of string option * domain list callback
  41   | Disk_usage of source * string * int64 callback
  42   | Download_dir_find0 of source * string * string * unit callback
  43   | Download_dir_tarball of source * string * download_dir_tarball_format * string * unit callback
  44   | Download_file of source * string * string * unit callback
  45   | Open_domain of string * inspection_data callback
  46   | Open_images of (string * string option) list * inspection_data callback
  47   | Read_directory of source * string * direntry list callback
  48
  49 and domain = {
  50   dom_id : int;
  51   dom_name : string;
  52   dom_state : D.state;
  53 }
  54
  55 and inspection_data = {
  56   insp_all_filesystems : (string * string) list;
  57   insp_oses : inspection_os list;
  58 }
  59
  60 and inspection_os = {
  61   insp_root : string;
  62   insp_arch : string;
  63   insp_distro : string;
  64   insp_filesystems : string array;
  65   insp_hostname : string;
  66   insp_major_version : int;
  67   insp_minor_version : int;
  68   insp_mountpoints : (string * string) list;
  69   insp_package_format : string;
  70   insp_package_management : string;
  71   insp_product_name : string;
  72   insp_type : string;
  73   insp_windows_systemroot : string option;
  74   insp_winreg_DEFAULT : string option;
  75   insp_winreg_SAM : string option;
  76   insp_winreg_SECURITY : string option;
  77   insp_winreg_SOFTWARE : string option;
  78   insp_winreg_SYSTEM : string option;
  79 }
  80
  81 and source = OS of inspection_os | Volume of string
  82
  83 and direntry = {
  84   dent_name : string;
  85   dent_stat : G.stat;
  86   dent_link : string;
  87 }
  88
  89 and download_dir_tarball_format = Tar | TGZ | TXZ
  90
  91 let rec string_of_command = function
  92   | Exit_thread -> "Exit_thread"
  93   | Connect (Some name, _) -> sprintf "Connect %s" name
  94   | Connect (None, _) -> "Connect NULL"
  95   | Disk_usage (src, remotedir, _) ->
  96       sprintf "Disk_usage (%s, %s)" (string_of_source src) remotedir
  97   | Download_dir_find0 (src, remotedir, localfile, _) ->
  98       sprintf "Download_dir_find0 (%s, %s, %s)"
  99         (string_of_source src) remotedir localfile
 100   | Download_dir_tarball (src, remotedir, format, localfile, _) ->
 101       sprintf "Download_dir_tarball (%s, %s, %s, %s)"
 102         (string_of_source src) remotedir
 103         (string_of_download_dir_tarball_format format) localfile
 104   | Download_file (src, remotefile, localfile, _) ->
 105       sprintf "Download_file (%s, %s, %s)"
 106         (string_of_source src) remotefile localfile
 107   | Open_domain (name, _) -> sprintf "Open_domain %s" name
 108   | Open_images (images, _) ->
 109       sprintf "Open_images %s" (string_of_images images)
 110   | Read_directory (src, dir, _) ->
 111       sprintf "Read_directory (%s, %s)" (string_of_source src) dir
 112
 113 and string_of_images images =
 114   "[" ^
 115     String.concat "; "
 116     (List.map (function
 117                | fn, None -> fn
 118                | fn, Some format -> sprintf "%s (%s)" fn format)
 119        images) ^ "]"
 120
 121 and string_of_source = function
 122   | OS { insp_root = root } ->
 123       sprintf "OS %s" root
 124   | Volume dev ->
 125       sprintf "Volume %s" dev
 126
 127 and string_of_download_dir_tarball_format = function
 128   | Tar -> "Tar"
 129   | TGZ -> "TGZ"
 130   | TXZ -> "TXZ"
 131
 132 let no_callback _ = ()
 133
 134 let failure_hook = ref (fun _ -> ())
 135 let busy_hook = ref (fun _ -> ())
 136 let idle_hook = ref (fun _ -> ())
 137 let status_hook = ref (fun _ -> ())
 138 let progress_hook = ref (fun _ -> ())
 139
 140 let set_failure_hook cb = failure_hook := cb
 141 let set_busy_hook cb = busy_hook := cb
 142 let set_idle_hook cb = idle_hook := cb
 143 let set_status_hook cb = status_hook := cb
 144 let set_progress_hook cb = progress_hook := cb
 145
 146 (* Execute a function, while holding a mutex.  If the function
 147  * fails, ensure we release the mutex before rethrowing the
 148  * exception.
 149  *)
 150 let with_lock m f =
 151   M.lock m;
 152   let r = try Left (f ()) with exn -> Right exn in
 153   M.unlock m;
 154   match r with
 155   | Left r -> r
 156   | Right exn -> raise exn
 157
 158 (* The queue of commands, and a lock and condition to protect it. *)
 159 let q = Q.create ()
 160 let q_discard = ref false
 161 let q_lock = M.create ()
 162 let q_cond = Cond.create ()
 163
 164 (* Send a command message to the slave thread. *)
 165 let send_to_slave ?fail cmd =
 166   debug "sending message %s to slave thread ..." (string_of_command cmd);
 167   with_lock q_lock (
 168     fun () ->
 169       Q.push (fail, cmd) q;
 170       Cond.signal q_cond
 171   )
 172
 173 let discard_command_queue () =
 174   with_lock q_lock (
 175     fun () ->
 176       Q.clear q;
 177       (* Discard the currently running command. *)
 178       q_discard := true
 179   )
 180
 181 let connect ?fail uri cb = send_to_slave ?fail (Connect (uri, cb))
 182 let disk_usage ?fail src remotedir cb =
 183   send_to_slave ?fail (Disk_usage (src, remotedir, cb))
 184 let download_dir_find0 ?fail src remotedir localfile cb =
 185   send_to_slave ?fail (Download_dir_find0 (src, remotedir, localfile, cb))
 186 let download_dir_tarball ?fail src remotedir format localfile cb =
 187   send_to_slave ?fail
 188     (Download_dir_tarball (src, remotedir, format, localfile, cb))
 189 let download_file ?fail src remotefile localfile cb =
 190   send_to_slave ?fail (Download_file (src, remotefile, localfile, cb))
 191 let open_domain ?fail name cb = send_to_slave ?fail (Open_domain (name, cb))
 192 let open_images ?fail images cb = send_to_slave ?fail (Open_images (images, cb))
 193 let read_directory ?fail src path cb =
 194   send_to_slave ?fail (Read_directory (src, path, cb))
 195
 196 (*----- Slave thread starts here -----*)
 197
 198 (* Set this to true to exit the thread. *)
 199 let quit = ref false
 200
 201 (* Handles.  These are not protected by locks because only the slave
 202  * thread has access to them.
 203  *)
 204 let conn = ref None
 205 let g = ref None
 206
 207 (* Run the callback unless someone set the q_discard flag while
 208  * we were running the command.
 209  *)
 210 let callback_if_not_discarded (cb : 'a callback) (arg : 'a) =
 211   let discard = with_lock q_lock (fun () -> !q_discard) in
 212   if not discard then
 213     GtkThread.async cb arg
 214
 215 (* Call 'f ()' with source mounted read-only.  Ensure that everything
 216  * is unmounted even if an exception is thrown.
 217  *)
 218 let with_mount_ro g src (f : unit -> 'a) : 'a =
 219   Std.finally (fun () -> g#umount_all ()) (
 220     fun () ->
 221       (* Do the mount - could be OS or single volume. *)
 222       (match src with
 223       | Volume dev -> g#mount_ro dev "/";
 224       | OS { insp_mountpoints = mps } ->
 225           (* Sort the mountpoint keys by length, shortest first. *)
 226           let cmp (a,_) (b,_) = compare (String.length a) (String.length b) in
 227           let mps = List.sort ~cmp mps in
 228           (* Mount the filesystems. *)
 229           List.iter (
 230             fun (mp, dev) -> g#mount_ro dev mp
 231           ) mps
 232       );
 233       f ()
 234   ) ()
 235
 236 (* Update the status bar. *)
 237 let status fs =
 238   let f str = GtkThread.async !status_hook str in
 239   ksprintf f fs
 240
 241 let rec loop () =
 242   debug "top of slave loop";
 243
 244   (* Get the next command. *)
 245   let fail, cmd =
 246     with_lock q_lock (
 247       fun () ->
 248         while Q.is_empty q do Cond.wait q_cond q_lock done;
 249         q_discard := false;
 250         Q.pop q
 251     ) in
 252
 253   debug "slave processing command %s ..." (string_of_command cmd);
 254
 255   (try
 256      GtkThread.async !busy_hook ();
 257      execute_command cmd
 258    with exn ->
 259      (* If the user provided an override ?fail parameter to the
 260       * original call, call that, else call the global hook.
 261       *)
 262      match fail with
 263      | Some cb -> GtkThread.async cb exn
 264      | None -> GtkThread.async !failure_hook exn
 265   );
 266
 267   (* If there are no more commands in the queue, run the idle hook. *)
 268   let empty = with_lock q_lock (fun () -> Q.is_empty q) in
 269   if empty then GtkThread.async !idle_hook ();
 270
 271   if !quit then Thread.exit ();
 272   loop ()
 273
 274 and execute_command = function
 275   | Exit_thread ->
 276       quit := true;
 277       close_all ()
 278
 279   | Connect (name, cb) ->
 280       let printable_name =
 281         match name with None -> "default hypervisor" | Some uri -> uri in
 282       status "Connecting to %s ..." printable_name;
 283
 284       close_all ();
 285       conn := Some (C.connect_readonly ?name ());
 286
 287       let conn = get_conn () in
 288       let doms = D.get_domains conn [D.ListAll] in
 289       let doms = List.map (
 290         fun d ->
 291           { dom_id = D.get_id d;
 292             dom_name = D.get_name d;
 293             dom_state = (D.get_info d).D.state }
 294       ) doms in
 295       let cmp { dom_name = n1 } { dom_name = n2 } = compare n1 n2 in
 296       let doms = List.sort ~cmp doms in
 297
 298       status "Connected to %s" printable_name;
 299       callback_if_not_discarded cb doms
 300
 301   | Disk_usage (src, remotedir, cb) ->
 302       status "Calculating disk usage of %s ..." remotedir;
 303
 304       let g = get_g () in
 305       let r =
 306         with_mount_ro g src (
 307           fun () ->
 308             g#du remotedir
 309         ) in
 310
 311       status "Finished calculating disk usage of %s" remotedir;
 312       callback_if_not_discarded cb r
 313
 314   | Download_dir_find0 (src, remotedir, localfile, cb) ->
 315       status "Downloading %s filenames to %s ..." remotedir localfile;
 316
 317       let g = get_g () in
 318       with_mount_ro g src (
 319         fun () ->
 320           g#find0 remotedir localfile
 321       );
 322
 323       status "Finished downloading %s" localfile;
 324       callback_if_not_discarded cb ()
 325
 326   | Download_dir_tarball (src, remotedir, format, localfile, cb) ->
 327       status "Downloading %s to %s ..." remotedir localfile;
 328
 329       let g = get_g () in
 330       let f = match format with
 331         | Tar -> g#tar_out
 332         | TGZ -> g#tgz_out
 333         | TXZ -> g#txz_out
 334       in
 335       with_mount_ro g src (
 336         fun () ->
 337           f remotedir localfile
 338       );
 339
 340       status "Finished downloading %s" localfile;
 341       callback_if_not_discarded cb ()
 342
 343   | Download_file (src, remotefile, localfile, cb) ->
 344       status "Downloading %s to %s ..." remotefile localfile;
 345
 346       let g = get_g () in
 347       with_mount_ro g src (
 348         fun () ->
 349           g#download remotefile localfile
 350       );
 351
 352       status "Finished downloading %s" localfile;
 353       callback_if_not_discarded cb ()
 354
 355   | Open_domain (name, cb) ->
 356       status "Opening %s ..." name;
 357
 358       let conn = get_conn () in
 359       let dom = D.lookup_by_name conn name in
 360       let xml = D.get_xml_desc dom in
 361       let images = get_disk_images_from_xml xml in
 362       open_disk_images images cb
 363
 364   | Open_images (images, cb) ->
 365       status "Opening disk images ...";
 366
 367       open_disk_images images cb
 368
 369   | Read_directory (src, dir, cb) ->
 370       status "Reading directory %s ..." dir;
 371
 372       let g = get_g () in
 373       let names, stats, links =
 374         with_mount_ro g src (
 375           fun () ->
 376             let names = g#ls dir in (* sorted and without . and .. *)
 377             let names = Array.to_list names in
 378             let stats = lstatlist_wrapper g dir names in
 379             let links = readlink_wrapper g dir names stats in
 380             names, stats, links
 381         ) in
 382       assert (
 383         let n = List.length names in
 384         n = List.length stats && n = List.length links
 385       );
 386       let entries = List.combine (List.combine names stats) links in
 387       let entries = List.map (
 388         fun ((name, stat), link) ->
 389           { dent_name = name; dent_stat = stat; dent_link = link }
 390       ) entries in
 391
 392       status "Finished reading directory %s" dir;
 393       callback_if_not_discarded cb entries
 394
 395 (* Expect to be connected, and return the current libvirt connection. *)
 396 and get_conn () =
 397   match !conn with
 398   | Some conn -> conn
 399   | None -> failwith "not connected to libvirt"
 400
 401 and get_g () =
 402   match !g with
 403   | Some g -> g
 404   | None -> failwith "no domain or disk image is open"
 405
 406 (* Close all libvirt and libguestfs handles. *)
 407 and close_all () =
 408   (match !conn with Some conn -> C.close conn | None -> ());
 409   conn := None;
 410   close_g ()
 411
 412 and close_g () =
 413   (match !g with Some g -> g#close () | None -> ());
 414   g := None
 415
 416 and get_disk_images_from_xml xml =
 417   let xml = Xml.parse_string xml in
 418
 419   (* Return the device nodes. *)
 420   let devices =
 421     match xml with
 422     | Xml.Element ("domain", _, children) ->
 423         let devices =
 424           List.filter_map (
 425             function
 426             | Xml.Element ("devices", _, devices) -> Some devices
 427             | _ -> None
 428           ) children in
 429         List.concat devices
 430     | _ ->
 431         failwith "get_xml_desc didn't return <domain/>" in
 432
 433   (* Look for <source attr_name=attr_val/> and return attr_val. *)
 434   let rec source_of attr_name = function
 435     | [] -> None
 436     | Xml.Element ("source", attrs, _) :: rest ->
 437         (try Some (List.assoc attr_name attrs)
 438          with Not_found -> source_of attr_name rest)
 439     | _ :: rest -> source_of attr_name rest
 440   in
 441
 442   (* Look for <driver type=attr_val/> and return attr_val. *)
 443   let rec format_of = function
 444     | [] -> None
 445     | Xml.Element ("driver", attrs, _) :: rest ->
 446         (try Some (List.assoc "type" attrs)
 447          with Not_found -> format_of rest)
 448     | _ :: rest -> format_of rest
 449   in
 450
 451   (* Look for <disk> nodes and return the sources (block devices) of those. *)
 452   let blkdevs =
 453     List.filter_map (
 454       function
 455       | Xml.Element ("disk", attrs, disks) ->
 456           let filename =
 457             try
 458               let typ = List.assoc "type" attrs in
 459               if typ = "file" then source_of "file" disks
 460               else if typ = "block" then source_of "dev" disks
 461               else None
 462             with
 463               Not_found -> None in
 464           (match filename with
 465            | None -> None
 466            | Some filename ->
 467                let format = format_of disks in
 468                Some (filename, format)
 469           );
 470       | _ -> None
 471     ) devices in
 472   blkdevs
 473
 474 (* The common code for Open_domain and Open_images which opens the
 475  * libguestfs handle, adds the disks, and launches the appliance.
 476  *)
 477 and open_disk_images images cb =
 478   debug "opening disk image %s" (string_of_images images);
 479
 480   close_g ();
 481   let g' = new G.guestfs () in
 482   g := Some g';
 483   let g = g' in
 484
 485   g#set_trace (trace ());
 486
 487   (* Uncomment the next line to pass the verbose flag from the command
 488    * line through to libguestfs.  This is not generally necessary since
 489    * we are not so interested in debugging libguestfs problems at this
 490    * level, and the user can always set LIBGUESTFS_DEBUG=1 if they need
 491    * to.
 492    *)
 493   (* g#set_verbose (verbose ());*)
 494
 495   (* Attach progress bar callback. *)
 496   g#set_progress_callback (
 497     fun proc_nr serial position total ->
 498       debug "progress callback proc_nr=%d serial=%d posn=%Ld total=%Ld"
 499         proc_nr serial position total;
 500       GtkThread.async !progress_hook (position, total)
 501   );
 502
 503   List.iter (
 504     function
 505     | filename, None ->
 506         g#add_drive_opts ~readonly:true filename
 507     | filename, Some format ->
 508         g#add_drive_opts ~readonly:true ~format filename
 509   ) images;
 510
 511   g#launch ();
 512
 513   status "Listing filesystems ...";
 514
 515   (* Get list of filesystems. *)
 516   let fses = g#list_filesystems () in
 517
 518   status "Looking for operating systems ...";
 519
 520   (* Perform inspection.  This can fail, ignore errors. *)
 521   let roots =
 522     try Array.to_list (g#inspect_os ())
 523     with
 524       G.Error msg ->
 525         debug "inspection failed (error ignored): %s" msg;
 526         [] in
 527
 528   let oses = List.map (
 529     fun root ->
 530       let typ = g#inspect_get_type root in
 531       let windows_systemroot =
 532         if typ <> "windows" then None
 533         else (
 534           try Some (g#inspect_get_windows_systemroot root)
 535           with G.Error _ -> None
 536         ) in
 537
 538       (* Create most of the OS object that we're going to return.  We
 539        * have to pass this to with_mount_ro below which is why we need
 540        * to partially create it here.
 541        *)
 542       let os = {
 543         insp_root = root;
 544         insp_arch = g#inspect_get_arch root;
 545         insp_distro = g#inspect_get_distro root;
 546         insp_filesystems = g#inspect_get_filesystems root;
 547         insp_hostname = g#inspect_get_hostname root;
 548         insp_major_version = g#inspect_get_major_version root;
 549         insp_minor_version = g#inspect_get_minor_version root;
 550         insp_mountpoints = g#inspect_get_mountpoints root;
 551         insp_package_format = g#inspect_get_package_format root;
 552         insp_package_management = g#inspect_get_package_management root;
 553         insp_product_name = g#inspect_get_product_name root;
 554         insp_type = typ;
 555         insp_windows_systemroot = windows_systemroot;
 556         insp_winreg_DEFAULT = None; (* incomplete, see below *)
 557         insp_winreg_SAM = None;
 558         insp_winreg_SECURITY = None;
 559         insp_winreg_SOFTWARE = None;
 560         insp_winreg_SYSTEM = None;
 561       } in
 562
 563       (* We need to mount the root in order to look for Registry hives. *)
 564       let winreg_DEFAULT, winreg_SAM, winreg_SECURITY, winreg_SOFTWARE,
 565         winreg_SYSTEM =
 566         match windows_systemroot with
 567         | None -> None, None, None, None, None
 568         | Some sysroot ->
 569             with_mount_ro g (OS os) (
 570               fun () ->
 571                 let check_for_hive filename =
 572                   let path =
 573                     sprintf "%s/system32/config/%s" sysroot filename in
 574                   try Some (g#case_sensitive_path path)
 575                   with G.Error _ -> None
 576                 in
 577                 check_for_hive "default",
 578                 check_for_hive "sam",
 579                 check_for_hive "security",
 580                 check_for_hive "software",
 581                 check_for_hive "system"
 582             ) in
 583
 584       (* Fill in the remaining struct fields. *)
 585       let os = { os with
 586                    insp_winreg_DEFAULT = winreg_DEFAULT;
 587                    insp_winreg_SAM = winreg_SAM;
 588                    insp_winreg_SECURITY = winreg_SECURITY;
 589                    insp_winreg_SOFTWARE = winreg_SOFTWARE;
 590                    insp_winreg_SYSTEM = winreg_SYSTEM
 591                } in
 592       os
 593   ) roots in
 594
 595   let data = {
 596     insp_all_filesystems = fses;
 597     insp_oses = oses;
 598   } in
 599
 600   status "Finished opening disk";
 601   callback_if_not_discarded cb data
 602
 603 (* guestfs_lstatlist has a "hidden" limit of the protocol message size.
 604  * Call this function, but split the list of names into chunks.
 605  *)
 606 and lstatlist_wrapper g dir = function
 607   | [] -> []
 608   | names ->
 609       let names', names = List.take 1000 names, List.drop 1000 names in
 610       let xs = g#lstatlist dir (Array.of_list names') in
 611       let xs = Array.to_list xs in
 612       xs @ lstatlist_wrapper g dir names
 613
 614 (* For each entry which is a symlink, read the destination of the
 615  * symlink.  This is non-trivial because on Windows we cannot use
 616  * readlink but need to instead parse the reparse data from NTFS.
 617  *)
 618 and readlink_wrapper g dir names stats =
 619   (* Is the directory on an NTFS filesystem? *)
 620   let dev = get_mounted_device g dir in
 621   if g#vfs_type dev <> "ntfs" then (
 622     (* Not NTFS, use the fast g#readlinklist method. *)
 623     let rec readlinklist_wrapper g dir = function
 624       | [] -> []
 625       | names ->
 626           let names', names = List.take 1000 names, List.drop 1000 names in
 627           let xs = g#readlinklist dir (Array.of_list names') in
 628           let xs = Array.to_list xs in
 629           xs @ readlinklist_wrapper g dir names
 630     in
 631     readlinklist_wrapper g dir names
 632   )
 633   else (
 634     (* NTFS: look up each symlink individually. *)
 635     List.map (
 636       fun (name, stat) ->
 637         if not (is_symlink stat.G.mode) then ""
 638         else
 639           let path = if dir = "/" then dir ^ name else dir ^ "/" ^ name in
 640           try
 641             let _, display = get_ntfs_reparse_data g path in
 642             display
 643           with exn ->
 644             debug "get_ntfs_reparse_data: %s: failed: %s"
 645               path (Printexc.to_string exn);
 646             "?"
 647     ) (List.combine names stats)
 648   )
 649
 650 (* See:
 651  * https://bugzilla.redhat.com/show_bug.cgi?id=663407
 652  * http://git.annexia.org/?p=libguestfs.git;a=commit;h=3a3836b933b80c4f9f2c767fda4f8b459f998db2
 653  * http://www.tuxera.com/community/ntfs-3g-advanced/junction-points-and-symbolic-links/
 654  * http://www.tuxera.com/community/ntfs-3g-advanced/extended-attributes/
 655  * http://www.codeproject.com/KB/winsdk/junctionpoints.aspx
 656  *)
 657 and get_ntfs_reparse_data g path =
 658   let data = g#lgetxattr path "system.ntfs_reparse_data" in
 659   let link, display =
 660     bitmatch Bitstring.bitstring_of_string data with
 661     (* IO_REPARSE_TAG_MOUNT_POINT *)
 662     | { 0xa0000003_l : 32 : littleendian;
 663         _ : 16 : littleendian; (* data length - ignore it *)
 664         _ : 16 : littleendian; (* reserved *)
 665         link_offset : 16 : littleendian;
 666         link_len : 16 : littleendian;
 667         display_offset : 16 : littleendian;
 668         display_len : 16 : littleendian;
 669         link : link_len * 8 :
 670           string, offset (8 * (link_offset + 0x10));
 671         display : display_len * 8 :
 672           string, offset (8 * (display_offset + 0x10)) } ->
 673           (* These strings should always be valid UTF16LE, but the caller
 674            * is prepared to catch any exception if this fails.
 675            *)
 676           let link = windows_string_to_utf8 link in
 677           let display = windows_string_to_utf8 display in
 678           link, display
 679     | { 0xa0000003_l : 32 : littleendian } ->
 680           invalid_arg (
 681             sprintf "%s: could not parse IO_REPARSE_TAG_MOUNT_POINT data" path
 682           )
 683
 684     (* IO_REPARSE_TAG_SYMLINK *)
 685     | { 0xa000000c_l : 32 : littleendian;
 686         _ : 16 : littleendian; (* data length - ignore it *)
 687         _ : 16 : littleendian; (* reserved *)
 688         link_offset : 16 : littleendian;
 689         link_len : 16 : littleendian;
 690         display_offset : 16 : littleendian;
 691         display_len : 16 : littleendian;
 692         link : link_len * 8 :
 693           string, offset (8 * (link_offset + 0x14));
 694         display : display_len * 8 :
 695           string, offset (8 * (display_offset + 0x14)) } ->
 696           let link = windows_string_to_utf8 link in
 697           let display = windows_string_to_utf8 display in
 698           link, display
 699     | { 0xa000000c_l : 32 : littleendian } ->
 700           invalid_arg (
 701             sprintf "%s: could not parse IO_REPARSE_TAG_SYMLINK data" path
 702           )
 703
 704     | { i : 32 : littleendian } ->
 705           invalid_arg (
 706             sprintf "%s: reparse data of type 0x%lx is not supported" path i
 707           )
 708     | { _ } ->
 709           invalid_arg (sprintf "%s: reparse data is too short" path) in
 710
 711   link, display
 712
 713 (* Given a path which is located somewhere on a mountpoint, return the
 714  * device name.  This works by using g#mountpoints and then looking for
 715  * the mount path with the longest match.
 716  *)
 717 and get_mounted_device g path =
 718   let mps = g#mountpoints () in
 719   let mps = List.map (
 720     fun (dev, mp) ->
 721       if String.starts_with path mp then dev, String.length mp else dev, 0
 722   ) mps in
 723   let cmp (_,n1) (_,n2) = compare n2 n1 in
 724   let mps = List.sort ~cmp mps in
 725   match mps with
 726   | [] ->
 727       invalid_arg (sprintf "%s: not mounted" path)
 728   | (_,0) :: _ ->
 729       invalid_arg (sprintf "%s: not found on any filesystem" path)
 730   | (dev,_) :: _ -> dev
 731
 732 (* Start up one slave thread. *)
 733 let slave_thread = Thread.create loop ()
 734
 735 (* Note the following function is called from the main thread. *)
 736 let exit_thread () =
 737   discard_command_queue ();
 738   ignore (send_to_slave Exit_thread);
 739   Thread.join slave_thread