Prepare for first binary release.

[guestfs-browser.git] / slave.ml

diff --git a/slave.ml b/slave.ml
index 17f00b7..880a2b1 100644 (file)
--- a/slave.ml
+++ b/slave.ml
@@ -32,6 +32,7 @@ type 'a callback = 'a -> unit
 type command =
   | Exit_thread
   | 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
@@ -80,6 +81,8 @@ let rec string_of_command = function
   | Exit_thread -> "Exit_thread"
   | Connect (Some name, _) -> sprintf "Connect %s" name
   | Connect (None, _) -> "Connect NULL"
+  | Disk_usage (src, remotedir, _) ->
+      sprintf "Disk_usage (%s, %s)" (string_of_source src) remotedir
   | Download_dir_find0 (src, remotedir, localfile, _) ->
       sprintf "Download_dir_find0 (%s, %s, %s)"
         (string_of_source src) remotedir localfile
@@ -120,11 +123,13 @@ let no_callback _ = ()
 let failure_hook = ref (fun _ -> ())
 let busy_hook = ref (fun _ -> ())
 let idle_hook = ref (fun _ -> ())
+let status_hook = ref (fun _ -> ())
 let progress_hook = ref (fun _ -> ())
 
 let set_failure_hook cb = failure_hook := cb
 let set_busy_hook cb = busy_hook := cb
 let set_idle_hook cb = idle_hook := cb
+let set_status_hook cb = status_hook := cb
 let set_progress_hook cb = progress_hook := cb
 
 (* Execute a function, while holding a mutex.  If the function
@@ -163,6 +168,8 @@ let discard_command_queue () =
   )
 
 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))
 let download_dir_find0 ?fail src remotedir localfile cb =
   send_to_slave ?fail (Download_dir_find0 (src, remotedir, localfile, cb))
 let download_dir_tarball ?fail src remotedir format localfile cb =
@@ -215,6 +222,11 @@ let with_mount_ro g src (f : unit -> 'a) : 'a =
       f ()
   ) ()
 
+(* Update the status bar. *)
+let status fs =
+  let f str = GtkThread.async !status_hook str in
+  ksprintf f fs
+
 let rec loop () =
   debug "top of slave loop";
 
@@ -254,6 +266,10 @@ and execute_command = function
       close_all ()
 
   | Connect (name, cb) ->
+      let printable_name =
+        match name with None -> "default hypervisor" | Some uri -> uri in
+      status "Connecting to %s ..." printable_name;
+
       close_all ();
       conn := Some (C.connect_readonly ?name ());
 
@@ -267,17 +283,38 @@ and execute_command = function
       ) doms in
       let cmp { dom_name = n1 } { dom_name = n2 } = compare n1 n2 in
       let doms = List.sort ~cmp doms in
+
+      status "Connected to %s" printable_name;
       callback_if_not_discarded cb doms
 
+  | Disk_usage (src, remotedir, cb) ->
+      status "Calculating disk usage of %s ..." remotedir;
+
+      let g = get_g () in
+      let r =
+        with_mount_ro g src (
+          fun () ->
+            g#du remotedir
+        ) in
+
+      status "Finished calculating disk usage of %s" remotedir;
+      callback_if_not_discarded cb r
+
   | Download_dir_find0 (src, remotedir, localfile, cb) ->
+      status "Downloading %s filenames to %s ..." remotedir localfile;
+
       let g = get_g () in
       with_mount_ro g src (
         fun () ->
           g#find0 remotedir localfile
       );
+
+      status "Finished downloading %s" localfile;
       callback_if_not_discarded cb ()
 
   | Download_dir_tarball (src, remotedir, format, localfile, cb) ->
+      status "Downloading %s to %s ..." remotedir localfile;
+
       let g = get_g () in
       let f = match format with
         | Tar -> g#tar_out
@@ -288,17 +325,25 @@ and execute_command = function
         fun () ->
           f remotedir localfile
       );
+
+      status "Finished downloading %s" localfile;
       callback_if_not_discarded cb ()
 
   | Download_file (src, remotefile, localfile, cb) ->
+      status "Downloading %s to %s ..." remotefile localfile;
+
       let g = get_g () in
       with_mount_ro g src (
         fun () ->
           g#download remotefile localfile
       );
+
+      status "Finished downloading %s" localfile;
       callback_if_not_discarded cb ()
 
   | Open_domain (name, cb) ->
+      status "Opening %s ..." name;
+
       let conn = get_conn () in
       let dom = D.lookup_by_name conn name in
       let xml = D.get_xml_desc dom in
@@ -306,9 +351,13 @@ and execute_command = function
       open_disk_images images cb
 
   | Open_images (images, cb) ->
+      status "Opening disk images ...";
+
       open_disk_images images cb
 
   | Read_directory (src, dir, cb) ->
+      status "Reading directory %s ..." dir;
+
       let g = get_g () in
       let names, stats, links =
         with_mount_ro g src (
@@ -328,6 +377,8 @@ and execute_command = function
         fun ((name, stat), link) ->
           { dent_name = name; dent_stat = stat; dent_link = link }
       ) entries in
+
+      status "Finished reading directory %s" dir;
       callback_if_not_discarded cb entries
 
 (* Expect to be connected, and return the current libvirt connection. *)
@@ -448,9 +499,13 @@ and open_disk_images images cb =
 
   g#launch ();
 
+  status "Listing filesystems ...";
+
   (* Get list of filesystems. *)
   let fses = g#list_filesystems () in
 
+  status "Looking for operating systems ...";
+
   (* Perform inspection.  This can fail, ignore errors. *)
   let roots =
     try Array.to_list (g#inspect_os ())
@@ -482,6 +537,8 @@ and open_disk_images images cb =
     insp_all_filesystems = fses;
     insp_oses = oses;
   } in
+
+  status "Finished opening disk";
   callback_if_not_discarded cb data
 
 (* guestfs_lstatlist has a "hidden" limit of the protocol message size.