X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=slave.ml;h=880a2b1d7ddd1f23c0adf3e176e040a930d9638d;hb=refs%2Ftags%2F0.1.1;hp=94fce75d2f6c06cab6fff5440acb93cf20884be6;hpb=b9e8c84588873568b7fdfaeb9beb85466e84c8fa;p=guestfs-browser.git

diff --git a/slave.ml b/slave.ml
index 94fce75..880a2b1 100644
--- a/slave.ml
+++ b/slave.ml
@@ -32,8 +32,12 @@ 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
   | Open_domain of string * inspection_data callback
-  | Open_images of string list * inspection_data callback
+  | Open_images of (string * string option) list * inspection_data callback
   | Read_directory of source * string * direntry list callback
 
 and domain = {
@@ -71,27 +75,62 @@ and direntry = {
   dent_link : string;
 }
 
+and download_dir_tarball_format = Tar | TGZ | TXZ
+
 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
+  | Download_dir_tarball (src, remotedir, format, localfile, _) ->
+      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
   | Open_domain (name, _) -> sprintf "Open_domain %s" name
   | Open_images (images, _) ->
-      sprintf "Open_images [%s]" (String.concat "; " images)
-  | Read_directory (OS { insp_root = root }, dir, _) ->
-      sprintf "Read_directory (OS %s, %s)" root dir
-  | Read_directory (Volume dev, dir, _) ->
-      sprintf "Read_directory (Volume %s, %s)" dev dir
+      sprintf "Open_images %s" (string_of_images images)
+  | Read_directory (src, dir, _) ->
+      sprintf "Read_directory (%s, %s)" (string_of_source src) dir
+
+and string_of_images images =
+  "[" ^
+    String.concat "; "
+    (List.map (function
+               | fn, None -> fn
+               | fn, Some format -> sprintf "%s (%s)" fn format)
+       images) ^ "]"
+
+and string_of_source = function
+  | OS { insp_root = root } ->
+      sprintf "OS %s" root
+  | Volume dev ->
+      sprintf "Volume %s" dev
+
+and string_of_download_dir_tarball_format = function
+  | Tar -> "Tar"
+  | TGZ -> "TGZ"
+  | TXZ -> "TXZ"
 
 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
  * fails, ensure we release the mutex before rethrowing the
@@ -112,11 +151,11 @@ let q_lock = M.create ()
 let q_cond = Cond.create ()
 
 (* Send a command message to the slave thread. *)
-let send_to_slave cmd =
+let send_to_slave ?fail cmd =
   debug "sending message %s to slave thread ..." (string_of_command cmd);
   with_lock q_lock (
     fun () ->
-      Q.push cmd q;
+      Q.push (fail, cmd) q;
       Cond.signal q_cond
   )
 
@@ -128,10 +167,20 @@ let discard_command_queue () =
       q_discard := true
   )
 
-let connect uri cb = send_to_slave (Connect (uri, 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 src path cb = send_to_slave (Read_directory (src, path, 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))
+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 =
+  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))
+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))
 
 (*----- Slave thread starts here -----*)
 
@@ -173,11 +222,16 @@ 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";
 
   (* Get the next command. *)
-  let cmd =
+  let fail, cmd =
     with_lock q_lock (
       fun () ->
         while Q.is_empty q do Cond.wait q_cond q_lock done;
@@ -191,11 +245,12 @@ let rec loop () =
      GtkThread.async !busy_hook ();
      execute_command cmd
    with exn ->
-     (* If a command or the callback fails, clear the command queue
-      * and run the failure hook in the main thread.
+     (* If the user provided an override ?fail parameter to the
+      * original call, call that, else call the global hook.
       *)
-     discard_command_queue ();
-     GtkThread.async !failure_hook exn
+     match fail with
+     | Some cb -> GtkThread.async cb exn
+     | None -> GtkThread.async !failure_hook exn
   );
 
   (* If there are no more commands in the queue, run the idle hook. *)
@@ -211,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 ());
 
@@ -224,9 +283,67 @@ 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
+        | TGZ -> g#tgz_out
+        | TXZ -> g#txz_out
+      in
+      with_mount_ro g src (
+        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
@@ -234,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 (
@@ -256,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. *)
@@ -305,18 +428,34 @@ and get_disk_images_from_xml xml =
     | _ :: rest -> source_of attr_name rest
   in
 
+  (* Look for <driver type=attr_val/> and return attr_val. *)
+  let rec format_of = function
+    | [] -> None
+    | Xml.Element ("driver", attrs, _) :: rest ->
+        (try Some (List.assoc "type" attrs)
+         with Not_found -> format_of rest)
+    | _ :: rest -> format_of rest
+  in
+
   (* Look for <disk> nodes and return the sources (block devices) of those. *)
   let blkdevs =
     List.filter_map (
       function
-      | Xml.Element ("disk", attrs, children) ->
-          (try
-             let typ = List.assoc "type" attrs in
-             if typ = "file" then source_of "file" children
-             else if typ = "block" then source_of "dev" children
-             else None
-           with
-             Not_found -> None)
+      | Xml.Element ("disk", attrs, disks) ->
+          let filename =
+            try
+              let typ = List.assoc "type" attrs in
+              if typ = "file" then source_of "file" disks
+              else if typ = "block" then source_of "dev" disks
+              else None
+            with
+              Not_found -> None in
+          (match filename with
+           | None -> None
+           | Some filename ->
+               let format = format_of disks in
+               Some (filename, format)
+          );
       | _ -> None
     ) devices in
   blkdevs
@@ -325,13 +464,15 @@ and get_disk_images_from_xml xml =
  * libguestfs handle, adds the disks, and launches the appliance.
  *)
 and open_disk_images images cb =
-  debug "opening disk image [%s]" (String.concat "; " images);
+  debug "opening disk image %s" (string_of_images images);
 
   close_g ();
   let g' = new Guestfs.guestfs () in
   g := Some g';
   let g = g' in
 
+  g#set_trace (trace ());
+
   (* Uncomment the next line to pass the verbose flag from the command
    * line through to libguestfs.  This is not generally necessary since
    * we are not so interested in debugging libguestfs problems at this
@@ -340,13 +481,31 @@ and open_disk_images images cb =
    *)
   (* g#set_verbose (verbose ());*)
 
-  List.iter g#add_drive_ro images;
+  (* 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)
+  );
+
+  List.iter (
+    function
+    | filename, None ->
+        g#add_drive_opts ~readonly:true filename
+    | filename, Some format ->
+        g#add_drive_opts ~readonly:true ~format filename
+  ) images;
 
   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 ())
@@ -378,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.