X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=slave.ml;h=f72a5aa159b99824842ba419bc1db53831f9c977;hb=fe4514d682e2f3bad517a764f97292c3d8a23a71;hp=94fce75d2f6c06cab6fff5440acb93cf20884be6;hpb=b9e8c84588873568b7fdfaeb9beb85466e84c8fa;p=guestfs-browser.git diff --git a/slave.ml b/slave.ml index 94fce75..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 @@ -17,81 +17,102 @@ *) 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 * bool * unit callback + | File_information of source * string * string 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 = { - 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; -} - -and source = OS of inspection_os | Volume of string - -and direntry = { - dent_name : string; - dent_stat : Guestfs.stat; - dent_link : string; -} + | 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 "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, 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.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 + | Run_command (cmd, _) -> + sprintf "Run_command %s" cmd + +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 +133,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 +149,28 @@ 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 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)) +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, 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 -----*) @@ -152,32 +191,16 @@ 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 + 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 +214,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. *) @@ -210,7 +234,24 @@ 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 + status "Connecting to %s ..." printable_name; + close_all (); conn := Some (C.connect_readonly ?name ()); @@ -222,11 +263,84 @@ and execute_command = function 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; 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, 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 + ); + + 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; + let conn = get_conn () in let dom = D.lookup_by_name conn name in let xml = D.get_xml_desc dom in @@ -234,18 +348,21 @@ 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 ( 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 @@ -256,8 +373,20 @@ 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 + | 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 @@ -305,18 +434,34 @@ and get_disk_images_from_xml xml = | _ :: rest -> source_of attr_name rest in + (* Look for 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 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 +470,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 + let g' = new G.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,65 +487,121 @@ and open_disk_images images cb = *) (* g#set_verbose (verbose ());*) - List.iter g#add_drive_ro images; + (* Attach progress bar callback. *) + 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 ( + 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 ()) with - Guestfs.Error msg -> + G.Error msg -> debug "inspection failed (error ignored): %s" msg; [] in let oses = List.map ( - fun root -> { - insp_root = root; - insp_arch = g#inspect_get_arch root; - insp_distro = g#inspect_get_distro root; - insp_filesystems = g#inspect_get_filesystems root; - insp_hostname = g#inspect_get_hostname root; - insp_major_version = g#inspect_get_major_version root; - insp_minor_version = g#inspect_get_minor_version root; - insp_mountpoints = g#inspect_get_mountpoints root; - insp_package_format = g#inspect_get_package_format root; - insp_package_management = g#inspect_get_package_management root; - insp_product_name = g#inspect_get_product_name root; - insp_type = g#inspect_get_type root; - insp_windows_systemroot = - try Some (g#inspect_get_windows_systemroot root) - with Guestfs.Error _ -> None - } + fun root -> + let typ = g#inspect_get_type root in + let windows_systemroot = + if typ <> "windows" then None + else ( + try Some (g#inspect_get_windows_systemroot root) + with G.Error _ -> None + ) in + + (* Create most of the OS object that we're going to return. We + * have to pass this to with_mount_ro below which is why we need + * to partially create it here. + *) + let os = { + insp_root = root; + insp_arch = g#inspect_get_arch root; + insp_distro = g#inspect_get_distro root; + insp_filesystems = g#inspect_get_filesystems root; + insp_hostname = g#inspect_get_hostname root; + insp_major_version = g#inspect_get_major_version root; + insp_minor_version = g#inspect_get_minor_version root; + insp_mountpoints = g#inspect_get_mountpoints root; + insp_package_format = g#inspect_get_package_format root; + insp_package_management = g#inspect_get_package_management root; + insp_product_name = g#inspect_get_product_name root; + insp_type = typ; + insp_windows_systemroot = windows_systemroot; + insp_winreg_DEFAULT = None; (* incomplete, see below *) + insp_winreg_SAM = None; + insp_winreg_SECURITY = None; + insp_winreg_SOFTWARE = None; + insp_winreg_SYSTEM = None; + } in + + (* We need to mount the root in order to look for Registry hives. *) + let winreg_DEFAULT, winreg_SAM, winreg_SECURITY, winreg_SOFTWARE, + winreg_SYSTEM = + match windows_systemroot with + | None -> None, None, None, None, None + | Some sysroot -> + with_mount_ro g (OS os) ( + fun () -> + let check_for_hive filename = + let path = + sprintf "%s/system32/config/%s" sysroot filename in + try Some (g#case_sensitive_path path) + with G.Error _ -> None + in + check_for_hive "default", + check_for_hive "sam", + check_for_hive "security", + check_for_hive "software", + check_for_hive "system" + ) in + + (* Fill in the remaining struct fields. *) + let os = { os with + insp_winreg_DEFAULT = winreg_DEFAULT; + insp_winreg_SAM = winreg_SAM; + insp_winreg_SECURITY = winreg_SECURITY; + insp_winreg_SOFTWARE = winreg_SOFTWARE; + insp_winreg_SYSTEM = winreg_SYSTEM + } in + os ) roots in + let data = { insp_all_filesystems = fses; insp_oses = oses; } in - 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 + status "Finished opening disk"; + callback_if_not_discarded cb data (* Start up one slave thread. *) let slave_thread = Thread.create loop ()