X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=slave.ml;h=f72a5aa159b99824842ba419bc1db53831f9c977;hb=04b7ac2ae61b6b556819d16e45751af6903b9712;hp=01105ef8700c143eadb89f83c684a3ccadb0f8f4;hpb=f09bb82de01019f24411cac2916d9567b5e9a235;p=guestfs-browser.git

diff --git a/slave.ml b/slave.ml
index 01105ef..f72a5aa 100644
--- a/slave.ml
+++ b/slave.ml
@@ -1,5 +1,5 @@
 (* Guestfs Browser.
- * Copyright (C) 2010 Red Hat Inc.
+ * Copyright (C) 2010-2011 Red Hat Inc.
  *
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -18,11 +18,12 @@
 
 open ExtList
 open ExtString
-open CamomileLibrary
-open Default.Camomile
 
 open Utils
 
+open Slave_types
+open Slave_utils
+
 open Printf
 
 module C = Libvirt.Connect
@@ -31,65 +32,31 @@ module D = Libvirt.Domain
 module G = Guestfs
 module M = Mutex
 module Q = Queue
+module UTF8 = CamomileLibraryDefault.Camomile.UTF8
+
 
 type 'a callback = 'a -> unit
 
 (* The commands. *)
 type command =
   | Exit_thread
+  | Checksum_file of source * string * string * string callback
   | Connect of string option * domain list callback
   | Disk_usage of source * string * int64 callback
   | Download_dir_find0 of source * string * string * unit callback
   | Download_dir_tarball of source * string * download_dir_tarball_format * string * unit callback
-  | Download_file of source * string * string * unit callback
+  | Download_file of source * string * string * bool * unit callback
+  | File_information of source * string * string callback
   | Open_domain of string * inspection_data callback
   | Open_images of (string * string option) list * inspection_data callback
   | Read_directory of source * string * direntry list callback
-
-and domain = {
-  dom_id : int;
-  dom_name : string;
-  dom_state : D.state;
-}
-
-and inspection_data = {
-  insp_all_filesystems : (string * string) list;
-  insp_oses : inspection_os list;
-}
-
-and inspection_os = {
-  insp_root : string;
-  insp_arch : string;
-  insp_distro : string;
-  insp_filesystems : string array;
-  insp_hostname : string;
-  insp_major_version : int;
-  insp_minor_version : int;
-  insp_mountpoints : (string * string) list;
-  insp_package_format : string;
-  insp_package_management : string;
-  insp_product_name : string;
-  insp_type : string;
-  insp_windows_systemroot : string option;
-  insp_winreg_DEFAULT : string option;
-  insp_winreg_SAM : string option;
-  insp_winreg_SECURITY : string option;
-  insp_winreg_SOFTWARE : string option;
-  insp_winreg_SYSTEM : string option;
-}
-
-and source = OS of inspection_os | Volume of string
-
-and direntry = {
-  dent_name : string;
-  dent_stat : G.stat;
-  dent_link : string;
-}
-
-and download_dir_tarball_format = Tar | TGZ | TXZ
+  | Run_command of string * unit callback
 
 let rec string_of_command = function
   | Exit_thread -> "Exit_thread"
+  | Checksum_file (src, pathname, csumtype, _) ->
+      sprintf "Checksum_file (%s, %s, %s)"
+        (string_of_source src) pathname csumtype
   | Connect (Some name, _) -> sprintf "Connect %s" name
   | Connect (None, _) -> "Connect NULL"
   | Disk_usage (src, remotedir, _) ->
@@ -101,14 +68,18 @@ let rec string_of_command = function
       sprintf "Download_dir_tarball (%s, %s, %s, %s)"
         (string_of_source src) remotedir
         (string_of_download_dir_tarball_format format) localfile
-  | Download_file (src, remotefile, localfile, _) ->
-      sprintf "Download_file (%s, %s, %s)"
-        (string_of_source src) remotefile localfile
+  | Download_file (src, remotefile, localfile, check, _) ->
+      sprintf "Download_file (%s, %s, %s, %b)"
+        (string_of_source src) remotefile localfile check
+  | File_information (src, pathname, _) ->
+      sprintf "File_information (%s, %s)" (string_of_source src) pathname
   | Open_domain (name, _) -> sprintf "Open_domain %s" name
   | Open_images (images, _) ->
       sprintf "Open_images %s" (string_of_images images)
   | Read_directory (src, dir, _) ->
       sprintf "Read_directory (%s, %s)" (string_of_source src) dir
+  | Run_command (cmd, _) ->
+      sprintf "Run_command %s" cmd
 
 and string_of_images images =
   "[" ^
@@ -178,6 +149,8 @@ let discard_command_queue () =
       q_discard := true
   )
 
+let checksum_file ?fail src pathname csumtype cb =
+  send_to_slave ?fail (Checksum_file (src, pathname, csumtype, cb))
 let connect ?fail uri cb = send_to_slave ?fail (Connect (uri, cb))
 let disk_usage ?fail src remotedir cb =
   send_to_slave ?fail (Disk_usage (src, remotedir, cb))
@@ -187,11 +160,17 @@ let download_dir_tarball ?fail src remotedir format localfile cb =
   send_to_slave ?fail
     (Download_dir_tarball (src, remotedir, format, localfile, cb))
 let download_file ?fail src remotefile localfile cb =
-  send_to_slave ?fail (Download_file (src, remotefile, localfile, cb))
+  send_to_slave ?fail (Download_file (src, remotefile, localfile, false, cb))
+let download_file_if_not_exist ?fail src remotefile localfile cb =
+  send_to_slave ?fail (Download_file (src, remotefile, localfile, true, cb))
+let file_information ?fail src pathname cb =
+  send_to_slave ?fail (File_information (src, pathname, cb))
 let open_domain ?fail name cb = send_to_slave ?fail (Open_domain (name, cb))
 let open_images ?fail images cb = send_to_slave ?fail (Open_images (images, cb))
 let read_directory ?fail src path cb =
   send_to_slave ?fail (Read_directory (src, path, cb))
+let run_command ?fail cmd cb =
+  send_to_slave ?fail (Run_command (cmd, cb))
 
 (*----- Slave thread starts here -----*)
 
@@ -212,27 +191,6 @@ let callback_if_not_discarded (cb : 'a callback) (arg : 'a) =
   if not discard then
     GtkThread.async cb arg
 
-(* Call 'f ()' with source mounted read-only.  Ensure that everything
- * is unmounted even if an exception is thrown.
- *)
-let with_mount_ro g src (f : unit -> 'a) : 'a =
-  Std.finally (fun () -> g#umount_all ()) (
-    fun () ->
-      (* Do the mount - could be OS or single volume. *)
-      (match src with
-      | Volume dev -> g#mount_ro dev "/";
-      | OS { insp_mountpoints = mps } ->
-          (* Sort the mountpoint keys by length, shortest first. *)
-          let cmp (a,_) (b,_) = compare (String.length a) (String.length b) in
-          let mps = List.sort ~cmp mps in
-          (* Mount the filesystems. *)
-          List.iter (
-            fun (mp, dev) -> g#mount_ro dev mp
-          ) mps
-      );
-      f ()
-  ) ()
-
 (* Update the status bar. *)
 let status fs =
   let f str = GtkThread.async !status_hook str in
@@ -276,6 +234,19 @@ and execute_command = function
       quit := true;
       close_all ()
 
+  | Checksum_file (src, pathname, csumtype, cb) ->
+      status "Calculating %s checksum of %s ..." csumtype pathname;
+
+      let g = get_g () in
+      let r =
+        with_mount_ro g src (
+          fun () ->
+            g#checksum csumtype pathname
+        ) in
+
+      status "Finished calculating %s checksum of %s" csumtype pathname;
+      callback_if_not_discarded cb r
+
   | Connect (name, cb) ->
       let printable_name =
         match name with None -> "default hypervisor" | Some uri -> uri in
@@ -340,18 +311,33 @@ and execute_command = function
       status "Finished downloading %s" localfile;
       callback_if_not_discarded cb ()
 
-  | Download_file (src, remotefile, localfile, cb) ->
-      status "Downloading %s to %s ..." remotefile localfile;
+  | Download_file (src, remotefile, localfile, check, cb) ->
+      if not check || not (local_file_exists localfile) then (
+        status "Downloading %s to %s ..." remotefile localfile;
 
-      let g = get_g () in
-      with_mount_ro g src (
-        fun () ->
-          g#download remotefile localfile
-      );
+        let g = get_g () in
+        with_mount_ro g src (
+          fun () ->
+            g#download remotefile localfile
+        );
 
-      status "Finished downloading %s" localfile;
+        status "Finished downloading %s" localfile
+      );
       callback_if_not_discarded cb ()
 
+  | File_information (src, pathname, cb) ->
+      status "Calculating file information for %s ..." pathname;
+
+      let g = get_g () in
+      let r =
+        with_mount_ro g src (
+          fun () ->
+            g#file pathname
+        ) in
+
+      status "Finished calculating file information for %s" pathname;
+      callback_if_not_discarded cb r
+
   | Open_domain (name, cb) ->
       status "Opening %s ..." name;
 
@@ -374,10 +360,9 @@ and execute_command = function
         with_mount_ro g src (
           fun () ->
             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 = readlink_wrapper g dir names stats in
-            names, stats, links
+            let stats = lstatlist g dir names in
+            let links = readlinks g dir names (Array.of_list stats) in
+            Array.to_list names, stats, links
         ) in
       assert (
         let n = List.length names in
@@ -392,6 +377,16 @@ and execute_command = function
       status "Finished reading directory %s" dir;
       callback_if_not_discarded cb entries
 
+  | Run_command (cmd, cb) ->
+      status "Running %s ..." cmd;
+
+      if Sys.command cmd <> 0 then
+        failwith "External command failed: %s" cmd;
+
+      status "Finished %s ..." cmd;
+
+      callback_if_not_discarded cb ()
+
 (* Expect to be connected, and return the current libvirt connection. *)
 and get_conn () =
   match !conn with
@@ -493,11 +488,19 @@ and open_disk_images images cb =
   (* g#set_verbose (verbose ());*)
 
   (* Attach progress bar callback. *)
-  g#set_progress_callback (
-    fun proc_nr serial position total ->
-      debug "progress callback proc_nr=%d serial=%d posn=%Ld total=%Ld"
-        proc_nr serial position total;
-      GtkThread.async !progress_hook (position, total)
+  ignore (
+    g#set_event_callback (
+      fun g event handle buf array ->
+        if event == G.EVENT_PROGRESS && Array.length array >= 4 then (
+          let proc_nr = array.(0)
+          and serial = array.(1)
+          and position = array.(2)
+          and total = array.(3) in
+          debug "progress callback proc_nr=%Ld serial=%Ld posn=%Ld total=%Ld"
+            proc_nr serial position total;
+          GtkThread.async !progress_hook (position, total)
+        )
+    ) [ G.EVENT_PROGRESS ]
   );
 
   List.iter (
@@ -600,135 +603,6 @@ and open_disk_images images cb =
   status "Finished opening disk";
   callback_if_not_discarded cb data
 
-(* guestfs_lstatlist has a "hidden" limit of the protocol message size.
- * Call this function, but split the list of names into chunks.
- *)
-and lstatlist_wrapper g dir = function
-  | [] -> []
-  | names ->
-      let names', names = List.take 1000 names, List.drop 1000 names in
-      let xs = g#lstatlist dir (Array.of_list names') in
-      let xs = Array.to_list xs in
-      xs @ lstatlist_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 ()