(* 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
*)
open ExtList
-open Printf
+open ExtString
+
open Utils
+open Slave_types
+open Slave_utils
+
+open Printf
+
module C = Libvirt.Connect
module Cond = Condition
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 : Guestfs.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, _) ->
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 =
"[" ^
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))
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 -----*)
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
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
dom_name = D.get_name d;
dom_state = (D.get_info d).D.state }
) doms in
- let cmp { dom_name = n1 } { dom_name = n2 } = compare n1 n2 in
+ let cmp { dom_name = n1 } { dom_name = n2 } = UTF8.compare n1 n2 in
let doms = List.sort ~cmp doms in
status "Connected to %s" printable_name;
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;
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 = readlinklist_wrapper g dir names 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
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
debug "opening disk image %s" (string_of_images images);
close_g ();
- let g' = new Guestfs.guestfs () in
+ let g' = new G.guestfs () in
g := Some g';
let g = g' in
(* 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 (
let roots =
try Array.to_list (g#inspect_os ())
with
- Guestfs.Error msg ->
+ G.Error msg ->
debug "inspection failed (error ignored): %s" msg;
[] in
if typ <> "windows" then None
else (
try Some (g#inspect_get_windows_systemroot root)
- with Guestfs.Error _ -> None
+ with G.Error _ -> None
) in
(* Create most of the OS object that we're going to return. We
let path =
sprintf "%s/system32/config/%s" sysroot filename in
try Some (g#case_sensitive_path path)
- with Guestfs.Error _ -> None
+ with G.Error _ -> None
in
check_for_hive "default",
check_for_hive "sam",
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
-
-(* Same as above for guestfs_readlinklist. *)
-and 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
-
(* Start up one slave thread. *)
let slave_thread = Thread.create loop ()