Version 0.0.3.

[guestfs-browser.git] / slave.ml

diff --git a/slave.ml b/slave.ml
index d1cff80..ba45cfb 100644 (file)
--- a/slave.ml
+++ b/slave.ml
@@ -38,6 +38,8 @@ type command =
   | Open_images of string list * rw_flag callback
   | Get_volumes of volume callback
   | Read_directory of string * string * direntry list callback
+  | Disk_usage of string * string * int64 callback
+  | Export_dir_to of export_t * string * string * string * unit callback
 
 and domain = {
   dom_id : int;
@@ -61,7 +63,13 @@ and direntry = {
   dent_link : string;
 }
 
-let string_of_command = function
+and export_t =
+  | Export_tar
+  | Export_tgz
+  | Export_checksums of string
+  | Export_list
+
+let rec string_of_command = function
   | Exit_thread -> "Exit_thread"
   | Connect (Some name, _) -> sprintf "Connect %s" name
   | Connect (None, _) -> "Connect NULL"
@@ -71,8 +79,17 @@ let string_of_command = function
       sprintf "Open_images [%s]" (String.concat "; " images)
   | Get_volumes _ -> "Get_volumes"
   | Read_directory (dev, dir, _) -> sprintf "Read_directory %s %s" dev dir
+  | Disk_usage (dev, dir, _) -> sprintf "Disk_usage %s %s" dev dir
+  | Export_dir_to (t, dev, dir, file, _) ->
+      sprintf "Export_dir_to %s %s %s %s" (string_of_export_t t) dev dir file
+
+and string_of_export_t = function
+  | Export_tar -> "Export_tar"
+  | Export_tgz -> "Export_tgz"
+  | Export_checksums alg -> sprintf "Export_checksums %s" alg
+  | Export_list -> "Export_list"
 
-let string_of_rw_flag = function RO -> "RO" | RW -> "RW"
+and string_of_rw_flag = function RO -> "RO" | RW -> "RW"
 
 let no_callback _ = ()
 
@@ -118,6 +135,9 @@ let get_volumes cb = send_to_slave (Get_volumes cb)
 let open_domain name cb = send_to_slave (Open_domain (name, cb))
 let open_images images cb = send_to_slave (Open_images (images, cb))
 let read_directory dev dir cb = send_to_slave (Read_directory (dev, dir, cb))
+let disk_usage dev dir cb = send_to_slave (Disk_usage (dev, dir, cb))
+let export_dir_to t dev dir file cb =
+  send_to_slave (Export_dir_to (t, dev, dir, file, cb))
 
 (*----- Slave thread starts here -----*)
 
@@ -141,6 +161,8 @@ let with_mount_ro g dev (f : unit -> 'a) : 'a =
   ) ()
 
 let rec loop () =
+  debug "thread id %d: top of slave loop ..." (Thread.id (Thread.self ()));
+
   (* Get the next command. *)
   let cmd =
     with_lock q_lock (
@@ -247,6 +269,23 @@ and execute_command = function
       ) entries in
       GtkThread.async cb entries
 
+  | Disk_usage (dev, dir, cb) ->
+      let g = get_g () in
+      let kb = with_mount_ro g dev (fun () -> G.du g dir) in
+      GtkThread.async cb kb
+
+  | Export_dir_to (t, dev, dir, file, cb) ->
+      let g = get_g () in
+      with_mount_ro g dev (
+        fun () ->
+          (match t with
+           | Export_tar -> G.tar_out g
+           | Export_tgz -> G.tgz_out g
+           | Export_checksums alg -> G.checksums_out g alg
+           | Export_list -> G.find0 g) dir file
+      );
+      GtkThread.async cb ()
+
 (* Expect to be connected, and return the current libvirt connection. *)
 and get_conn () =
   match !conn with